'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