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.
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.
 
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
 
Thank you for the effort. Forgive my ignorance, but how, exactly, do I use your code and get it into Outlook?
 
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
J Outlook 365 Outlook Macro to Sort emails by column "Received" to view the latest email received Outlook VBA and Custom Forms 0
S Adding a recipient's column to Sent folder in Outlook 2010 Outlook VBA and Custom Forms 1
ad24rouse Column Width of To-Do Bar Using Outlook 5
P How to add a column named categories when searching in Outlook Using Outlook 0
T Can't reposition "Flag Status" column Using Outlook 0
HappyDaddy007 "Size" on field chooser/column displaying incorrect value Using Outlook 3
P Posts in Folder No Longer Group by Conversation Column After Search Using Outlook 0
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
J Outlook 2010 Inbox sort FROM column not working Using Outlook 29
S Custom Yes/No column field Outlook VBA and Custom Forms 2
T How to find or display the sub-folder name for an Archive Search Using Outlook 10
Witzker Outlook 2019 Display the output of a seach in a new Window Outlook VBA and Custom Forms 6
Albert McCann Outlook 2021 Outlook Display of HTML Email from two senders is glitchy Using Outlook 0
K Outlook 365 After migrating to Outlook 365, some contacts display in emails with prefixes Using Outlook 0
K Daily Task List Minimized Cannot Display Using Outlook 5
J images on note field display fraction of size Using Outlook 5
J Outlook 2016 Can't display some embedded HTML images in Outlook 2016 Using Outlook 2
O After filtering, how to display all events on that day? Using Outlook 4
M All fonts in Outlook emails display with exaggerated character spacing Using Outlook 4
G Schedule recurring email and attachments display Outlook VBA and Custom Forms 3
O Tasks - how to display "snoozed" tasks and snooze-times? Using Outlook 7
P Task display now leaves little room for notes Using Outlook 10
R Capture Sender's Display name and Address Outlook VBA and Custom Forms 3
Travis Lloyd Messages Won't Display In Outlook 2019 Home & Business Using Outlook 0
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

Similar threads

Back
Top