I'm frequently asked how to display the recipient's email address in the Sent Items folder. The answer is this macro, which adds a custom field containing the addresses the message was sent to. The custom address field is a text field and you can sort or group by it.
Note that when a message is sent to multiple people, all addresses will be entered in the field as one long string, as seen in this example.
/o=ExchangeLabs/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Recipients/cn=43dfb970e3b54f85942d1348b58581e6-drcp;firstname.lastname@example.org;
Exchange server addresses are the x.500 address (as seen in the example above), not the SMTP address, however, you can use the Right() function to keep just the alias.
Public Sub GetRecipientAddress() ' //slipstick.me/9vjgj Dim currentExplorer As Explorer Dim Selection As Selection Dim obj, objMail As Object Dim objProp As Outlook.UserProperty Dim strDomain Dim Recipients As Outlook.Recipients Dim recip As String Dim i Dim prompt As String Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection On Error Resume Next For Each obj In Selection Set objMail = obj strDomain = "" Set Recipients = objMail.Recipients For i = Recipients.count To 1 Step -1 recip$ = Recipients.item(i).Address ' To use only the alias from the x.500 address ' If InStr(1, LCase(recip), "/ou=") Then recip = Right(recip, Len(recip) - InStr(1, LCase(recip), "recipients") - 13) ' Use semicolon separator if there is more than 1 address If i = 1 Then strDomain = strDomain & recip Else strDomain = strDomain & recip & "; " End If Next i Debug.Print strDomain Set objProp = objMail.UserProperties.Add("Recipient Email", olText, True) objProp.Value = strDomain objMail.Save Err.Clear Next Set currentExplorer = Nothing Set obj = Nothing Set Selection = Nothing End Sub
Add the field automatically
To add the recipient address field automatically, you need to use an ItemAdd macro. These macros need to be in ThisOutlookSession. To test, click in the Application_Startup macro and click Run then send a message.
Dim WithEvents olSent As Items Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set olSent = NS.GetDefaultFolder(olFolderSentMail).Items Set NS = Nothing End Sub Private Sub olSent_ItemAdd(ByVal Item As Object) ' From //slipstick.me/1 Dim objProp As Outlook.UserProperty Dim strDomain As String Dim Recipients As Outlook.Recipients Dim recip As String 'Outlook.Recipient Dim i strDomain = "" Set Recipients = Item.Recipients For i = Recipients.count To 1 Step -1 recip$ = Recipients.Item(i).Address 'If InStr(1, LCase(recip), "/ou=") Then recip = Right(recip, Len(recip) - InStr(1, LCase(recip), "recipients") - 13) If i = 1 Then strDomain = strDomain & recip Else strDomain = strDomain & recip & "; " End If Next i Set objProp = Item.UserProperties.Add("Recipient Email", olText, True) objProp.Value = strDomain Item.Save Err.Clear Set objProp = Nothing Set Recipients = Nothing End Sub
How to use this macro
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor