Discussion :

[joe.levrai]

Bonjour,

Je cherche à récupérer les différentes adresses de messagerie qui pointent sur une même boîte mail.

En gros, le SMTP principal et les smtp secondaires

On peut les consulter en faisant un clic-droit sur le contact >> Propriété >> Adresses de messagerie

Après avoir épluché les propriétés offertes, je n'ai pas trouvé mon bonheur

[Oliv-]

Salut,
c'est cadeau

Code :

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
Sub GetAliasFromdefaultuser()
'---------------------------------------------------------------------------------------
' Procedure : GetAliasFromRecipient
' Author    : Oliv
' Date      : 22/11/2018
' 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)
    Set Wk = Application.Workbooks.Add
    Set WS = Wk.ActiveSheet
    WS.Cells(1, 1).Value = "ALIAS"
    For i = 0 To UBound(AliasArray) - 1
        WS.Cells(i + 2, 1).Value = Split(AliasArray(i), ":")(1)
    Next i
 
    WS.Cells(1, 3).Value = "PRIMARYSMTP"
    WS.Cells(2, 3).Value = exc.PrimarySmtpAddress
 
End Sub

[joe.levrai]

Salut,

ah ! Merci, j'ai toujours du mal à trouver la PropTag qui va bien

J'ai adapté à mon besoin : boucler sur le carnet d'adresse globale et extraire les alias

Code :

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
Sub GetAliasFromGlobalAddressEntry()
    Dim myOlApp As Object
    Dim AliasArray
    Dim i As Long, j As Long
    Dim AllGal As Object, Exc As Object, Dest As Object
    Dim Wb As Workbook, Ws As Worksheet
 
    Const PR_EMS_AB_PROXY_ADDRESSES = "http://schemas.microsoft.com/mapi/proptag/0x800F101F"
 
    On Error Resume Next
    If StrComp(Application, "Outlook", vbTextCompare) = 0 Then
        Set myOlApp = Application
    Else
        Set myOlApp = CreateObject("outlook.application")
    End If
 
    Set AllGal = myOlApp.Session.GetGlobalAddressList().AddressEntries
    With Application.Workbooks.Add
        With .ActiveSheet
            .Cells(1, 1).Value = "Adresse Principale"
 
            For i = 1 To AllGal.Count
                Set Dest = AllGal.Item(i)
                Set Exc = Dest.GetExchangeUser
                AliasArray = Dest.propertyAccessor.GetProperty(PR_EMS_AB_PROXY_ADDRESSES)
 
                .Cells(i + 1, 1).Value = Exc.PrimarySmtpAddress
 
                For j = 0 To UBound(AliasArray) - 1
                    .Cells(i + 1, j + 2).Value = Split(AliasArray(j), ":")(1)
                Next j
            Next i
 
            .Cells(1, 2).Resize(1, .UsedRange.Columns.Count - 1).Value = "ALIAS"
        End With
    End With
End Sub