1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
|
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
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 |