Oliv-

Si vous avez un compte EXCHANGE avec plusieurs adresses Emails associées (= ALIAS), quand vous recevez un Email, vous ne savez pas sur quelle adresse on vous a envoyé cet Email.

L'information se trouve dans les en-têtes internet du message. Ou pas ! Par exemple l'envoi en CCI (BCC) ou à une liste de diffusion.

Voici une méthode pour retrouver l'information et l'afficher dans l'explorateur.

Le principe consiste à ajouter une propriété aux messages contenant cette info, à l'arrivée des Messages.

AJOUTEZ CECI A ThisOutlookSession. et RELANCEZ OUTLOOK en activant les MACROS.

Code VB :

Sélectionner tout - Visualiser dans une fenêtre à part

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
'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

CETTE PARTIE PEUT ETRE DANS UN MODULE ou dans ThisOutlookSession.

Code VB :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Dans l'explorateur
Cliquez bouton droit sur les intitulés de colonnes, et "SELECTEUR DE CHAMPS"
Dans le menu déroulant choisissez "Champs utilisateurs bte réception"
déplacez "Alias" vers les colonnes.


Voilà à l'arrivée d'un nouvel Email l'information va se renseigner.

Si vous souhaitez afficher cette info pour les Emails déjà reçus utilisez la macro GetEmailAddressesAlias en sélectionnant au préalable l'ensemble des Emails concernés.