Column to display which email alias a message was sent to

Post number 4 has been selected as the best answer.

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. :)
 
Top