Column to display which email alias a message was sent to

Post number 4 has been selected as the best answer.

Status
Not open for further replies.

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
That method won't work for recipients because when the mail is sent to a secondary address on an exchange account, the main address is shown in the to field. The address will be in the message header as long as it wasn't Bcc'd - the address is not in the header when a message is BCC to it.

It is possible to use a macro to get the address from the header and enter it into a custom field. Or use a rule to set a category for each address.
 

oliv-

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
Hi,
Try this
Code:
'https://social.technet.microsoft.com/Forums/office/de-DE/7196cf81-7822-48bd-8ac5-96ae46566255/how-to-show-email-address-not-just-name-in-from-and-to-fields?forum=outlook
' Mixed and matched from the following sources:
' http://www.slipstick.com/developer/code-samples/outlooks-internet-headers/
' http://www.slipstick.com/developer/recipient-email-address-sent-items/
' adapted to exchange alias  by Oliv

' Paste this into "ThisOutlookSession" and restart Outlook.
' This will then add "Alias" propertie
' to all messages arriving in Inbox.

Option Explicit
Dim WithEvents colInboxItems As Items
Private Sub Application_Startup()
  Dim objNS As Outlook.Namespace
  Set objNS = Application.session
  ' default local Inbox
  Set colInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub colInboxItems_ItemAdd(ByVal item As Object)

    On Error GoTo ErrorHandler
    Dim Msg As Object    'Outlook.MailItem
    Dim strHeader As String, strValue_To, strValue_CC, strAlias
    Dim strValue1 As String
    Dim strValue2 As String
    Dim objProp1 As Object    'Outlook.UserProperty
    Dim objProp2 As Object    'Outlook.UserProperty
    Dim AliasArray As Variant
    Dim i As Integer

    If TypeName(item) = "MailItem" Then
        Set Msg = item

        strHeader = GetInetHeaders(Msg)
        strValue_To = ParseEmailHeader(strHeader, "To")
        strValue_CC = ParseEmailHeader(strHeader, "CC")

        AliasArray = GetAliasFromCurrentUser()

        For i = 0 To UBound(AliasArray) - 1
            If InStr(1, strValue_To, Split(AliasArray(i), ":")(1), vbTextCompare) > 0 Then
                strAlias = Split(AliasArray(i), ":")(1)
                Exit For
            End If
        Next i
        If strAlias = "" Then
            For i = 0 To UBound(AliasArray) - 1
                If InStr(1, strValue_CC, Split(AliasArray(i), ":")(1), vbTextCompare) > 0 Then
                    strAlias = Split(AliasArray(i), ":")(1)
                    Exit For
                End If
            Next i
        End If
        Const olText = 1
        Set objProp1 = Msg.UserProperties.Add("Alias", olText, True)
        objProp1.Value = strAlias
        Msg.Save

    End If
ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub


Sub GetEmailAddressesAlias()
' Macro that can be run manually (does the same as above, on any selected messages)
    Dim olItem As Object
    Dim Msg As Object
    Dim strHeader As String, strValue_To, strValue_CC, strAlias
    Dim strValue1 As String
    Dim strValue2 As String
    Dim objProp1 As Object    'Outlook.UserProperty
    Dim objProp2 As Object    'Outlook.UserProperty
    Dim myOlApp  As Object
    Dim AliasArray As Variant
    Dim i As Integer
    
    If StrComp(Application, "Outlook", vbTextCompare) = 0 Then
        Set myOlApp = Application
    Else
        Set myOlApp = CreateObject("outlook.application")
    End If

    For Each olItem In myOlApp.ActiveExplorer.Selection
        If TypeName(olItem) = "MailItem" Then
            Set Msg = olItem

            strHeader = GetInetHeaders(Msg)
            strValue_To = ParseEmailHeader(strHeader, "To")
            strValue_CC = ParseEmailHeader(strHeader, "CC")

            AliasArray = GetAliasFromCurrentUser()

            For i = 0 To UBound(AliasArray) - 1
                If InStr(1, strValue_To, Split(AliasArray(i), ":")(1), vbTextCompare) > 0 Then
                    strAlias = Split(AliasArray(i), ":")(1)
                    Exit For
                End If
            Next i
            If strAlias = "" Then
                For i = 0 To UBound(AliasArray) - 1
                    If InStr(1, strValue_CC, Split(AliasArray(i), ":")(1), vbTextCompare) > 0 Then
                        strAlias = Split(AliasArray(i), ":")(1)
                        Exit For
                    End If
                Next i
            End If
            Const olText = 1
            Set objProp1 = Msg.UserProperties.Add("Alias", olText, True)
            objProp1.Value = strAlias

            '            Set objProp2 = Msg.UserProperties.Add("From Email", olText, True)
            '            objProp2.Value = strValue2

            Msg.Save
        End If
    Next
End Sub

Function GetInetHeaders(olkMsg As Object) As String
' Purpose: Returns the internet headers of a message.'
' Written: 4/28/2009'
' Author:  BlueDevilFan'
' http://techniclee.wordpress.com/
' Outlook: 2007'
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
    Dim olkPA As Object
    Set olkPA = olkMsg.propertyAccessor
    GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    Set olkPA = Nothing
End Function



Function ParseEmailHeader(strHeader As String, strReq As String, Optional sens As String) As String
    Dim strResult As String
    Dim strResults As String
    Dim Reg1 As Object
    Dim Reg2 As Object
    Dim M1 As Object
    Dim M As Object
    Dim M2 As Object
    Dim MM As Object

    Set Reg1 = CreateObject("VBScript.RegExp")
    With Reg1
        '.Pattern = "(\n" & strReq & ":\s([^\n]*))"
        .Pattern = "^" & strReq & ":([\x00-\xff]*?[\n\r\f]*?)[\n\r\f]*?.*?:"
        '.Pattern = "^(CC|To): (.*)(\n\s+(.*))*"
        .Global = True
        .ignorecase = True
        .MultiLine = True
    End With

    If Reg1.test(strHeader) Then
        Set M1 = Reg1.Execute(strHeader)
        Set Reg2 = CreateObject("VBScript.RegExp")
        With Reg2
            '.Pattern = "\b([^\s]+@[^\s]+)\b"
            'https://emailregex.com/

            .Pattern = "\b[A-Za-z0-9&._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,6}\b"
            .Global = True
            .ignorecase = True
            .MultiLine = False
        End With
        For Each M In M1
            'Debug.Print M.SubMatches(0)
            strResult = M.submatches(0)
            strResult = Replace(strResult, Chr(10) & Chr(13), " ")
            strResult = Replace(strResult, Chr(10), " ")
            strResult = Replace(strResult, Chr(13), " ")
            'Debug.Print strResult
            If Reg2.test(strResult) Then
                Set M2 = Reg2.Execute(strResult)
                strResult = ""
                For Each MM In M2
                    
                    If strResult = "" Then
                        strResult = strResult & MM.Value
                    Else
                        strResult = strResult & ";" & MM.Value
                    End If
                    'strResult = strResult & MM.SubMatches(0) & " "
                Next
            End If

            strResults = strResults & strResult & " "
        Next
    End If
    ParseEmailHeader = strResults
    Set Reg1 = Nothing
    Set M1 = Nothing
    Set M = Nothing
    Set M2 = Nothing
    Set MM = Nothing
End Function


Function GetAliasFromCurrentUser() As Variant
'---------------------------------------------------------------------------------------
' Procedure : GetAliasFromCurrentUser
' Author    : Oliv
' Date      : 28/11/2019
' Purpose   :
'---------------------------------------------------------------------------------------
'

    Dim myOlApp
    Dim Dest, AliasArray, i
    On Error Resume Next
    If StrComp(Application, "Outlook", vbTextCompare) = 0 Then
        Set myOlApp = Application
    Else
        Set myOlApp = CreateObject("outlook.application")
    End If

    Set Dest = myOlApp.session.CurrentUser
    'Set Dest = Session.GetRecipientFromID("00000000DCA740C8C042101AB4B908002B2FE18201000000000000002F4F3D45584348414E47454C4142532F4F553D45584348414E47452041444D494E4953545241544956452047524F5550202846594449424F484632335350444C54292F434E3D524543495049454E54532F434E3D43464541444431393444304534314235414245344536424633343833354637382D4F43545500")
    Dim exc: Set exc = Dest.AddressEntry.GetExchangeUser
    Const PR_EMS_AB_PROXY_ADDRESSES = "http://schemas.microsoft.com/mapi/proptag/0x800F101F"
    AliasArray = Dest.AddressEntry.propertyAccessor.GetProperty(PR_EMS_AB_PROXY_ADDRESSES)
    GetAliasFromCurrentUser = AliasArray
End Function
 

tsg

New Member
Outlook version
Outlook 2019 64-bit
Email Account
Exchange Server
Thank you for the effort. Forgive my ignorance, but how, exactly, do I use your code and get it into Outlook?
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Cool. 'Cos I've been offline stuffing myself with turkey and pumpkin pie. :)
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
O How to display senders email address (column) Using Outlook 1
G Wrong display name in from column when removing pf replication Exchange Server Administration 1
M Sorting by Day in Date Column Advanced Filter BCM (Business Contact Manager) 1
O Outlook tasks - Add text column with multiple lines Using Outlook 3
D Inbox column color coding Using Outlook 2
S Create a clickable custom column field Outlook VBA and Custom Forms 0
O Tasks - Is there a postponed date column? Using Outlook 7
N Column view fonts Using Outlook 4
D Column for To Email Address Using Outlook 0
H "Advanced find: column for full folder path? Using Outlook 1
A Can't add a column called "name" to Inbox? Using Outlook 1
D Email Icon Column Using Outlook 2
H SQL update column BCM (Business Contact Manager) 0
C How to copy same text header to multiple emails with custom text column Using Outlook 10
R Renaming Column Heading in Contacts view Using Outlook 6
T Column Header Keyboard Shortcut Available? Using Outlook 5
F Not keep sort order after re-change column Using Outlook 1
H Calendar column of time without date? Using Outlook 0
K Sent folder only shows "From", not "To" column Using Outlook 1
S Outlook 2007 Sort Column Shading Using Outlook 1
J From column changes when message is read Using Outlook 1
A How to replace column title in address book Using Outlook 1
B Populating Additional Outlook Column with Date \ Time Using Outlook 0
C placing contact and business phone column in task view Using Outlook 1
M IMAP: Attachment column gone from sent folder. Using Outlook 4
J Outlook 2010 Inbox sort FROM column not working Using Outlook 29
S Custom Yes/No column field Outlook VBA and Custom Forms 2
A Prepending Email Addrs with "Display Name <email>" Has Stopped Working Using Outlook 0
M In Outlook Calendar remove the buttons: 'Today' and '<' (Back a day) and '>' (Forward a day) that are below the Ribbon and above the calendar display. Using Outlook 0
C Why won't Title display in message list? Using Outlook 1
R Auto display of new email does not work on non-default account Outlook VBA and Custom Forms 0
E How to display "Change Folder" in Change Default Email Delivery Location in Exchange Outlook 2016 Using Outlook 1
M Daily Task List Minimized Cannot Display Using Outlook 2
C Outlook Mobile app email order randomized and display names stripped Using Outlook 6
N Contact display as Using Outlook 2
J Reminders Display then Disappear Using Outlook 13
S Display PF contact folder items to select contact to link to appointment Outlook VBA and Custom Forms 1
I How to display sender's name instead of email address in outlook 2013 message Using Outlook 5
O How to display number of items per .pst file Using Outlook 7
J Outlook 2016 message content does not display - outlook.com; exchange Using Outlook.com accounts in Outlook 9
O Display more months in 'Tasks' Using Outlook 3
soadfan Outlook rules look up display name only Using Outlook 4
C Display Sender As Contact Outlook VBA and Custom Forms 4
O How to display folder icons? Using Outlook 2
Treebys Array out of bounds .display 2016 Outlook VBA and Custom Forms 3
copperberry How to display incomplete tasks due on or before 7 days from now Using Outlook 0
T outlook 2010 mail item count doesnt match display Outlook VBA and Custom Forms 3
Diane Poremsky Category Color doesn't Display in Inbox New Slipstick.com Articles 0
P How to make outlook display alert appear on top of other windows whenever a new email is received? Outlook VBA and Custom Forms 1
T Outlook 2016 Calendar multiday event display Using Outlook 4

Similar threads

Top