Copier les contacts de la liste d'adresses globale, y compris les contacts externes

Question

J'ai un code VBA pour obtenir la liste d'adresses globale entière d'Outlook 2013 et placer les valeurs Name et dans une feuille Excel. Le problème est que je ne renvoie que des e-mails/utilisateurs de mon SMTP (je suppose).

Dans cette image, nous pouvons voir les utilisateurs du SMTP comme le mien couvert en noir et un utilisateur externe recouvert de rouge. Mon code:

Sub tgr() 

    Dim appOL As Object 
    Dim oGAL As Object 
    Dim oContact As Object 
    Dim oUser As Object 
    Dim arrUsers(1 To 75000, 1 To 2) As String 
    Dim UserIndex As Long 
    Dim i As Long 

    Set appOL = CreateObject("Outlook.Application") 

    Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries 

    For i = 1 To oGAL.Count 
     Set oContact = oGAL.Item(i) 
     If oContact.AddressEntryUserType = 0 Then 
      Set oUser = oContact.GetExchangeUser 
      If Len(oUser.lastname) > 0 Then 
       UserIndex = UserIndex + 1 
       arrUsers(UserIndex, 1) = oUser.Name 
       arrUsers(UserIndex, 2) = oUser.PrimarySMTPAddress 
      End If 
     End If 
    Next i 

    appOL.Quit 

    If UserIndex > 0 Then 
     Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers 
    End If 

    Set appOL = Nothing 
    Set oGAL = Nothing 
    Set oContact = Nothing 
    Set oUser = Nothing 
    Erase arrUsers 

End Sub 

Alors, est-ce que je fais quelque chose de mal?

Answer 1

Selon this documentation, la valeur oContact.AddressEntryUserType doit inclure olExchangeRemoteUserAddressEntry (5) pour les utilisateurs externes.

Ce qui est dans votre code est juste à la liste des utilisateurs Exchange, il saute également PublicFolders de messagerie, des listes de distribution, etc.

---

EDIT
trouvé une meilleure façon d'extraire le nom et l'adresse e-mail (le cas échéant):
Référence: Obtain the E-mail Address of a Recipient

Option Explicit 

Sub tgr() 
    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" 
    Dim appOL As Object 
    Dim oGAL As Object 
    Dim arrUsers() As String 
    Dim UserIndex As Long 
    Dim i As Long 
    Dim sEmail As String 

    Set appOL = GetObject(, "Outlook.Application") 
    If appOL Is Nothing Then Set appOL = CreateObject("Outlook.Application") 

    Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries 
    Debug.Print oGAL.Parent.Name & " has " & oGAL.Count & " entries" 
    ReDim arrUsers(1 To oGAL.Count, 1 To 2) 
    On Error Resume Next 
    For i = 1 To oGAL.Count 
     With oGAL.Item(i) 
      Application.StatusBar = "Processing GAL entry #" & i & " (" & .Name & ")" 
      sEmail = "" ' Not all entries has email address 
      sEmail = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS) 
      If Len(sEmail) = 0 Then Debug.Print "No Email address configured for " & .Name & " (#" & i & ")" 
      UserIndex = UserIndex + 1 
      arrUsers(UserIndex, 1) = .Name 
      arrUsers(UserIndex, 2) = sEmail 
     End With 
    Next 
    On Error GoTo 0 
    Application.StatusBar = False 
    appOL.Quit 

    If UserIndex > 0 Then 
     Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers 
    End If 

    Set appOL = Nothing 
    Set oGAL = Nothing 
    Erase arrUsers 

End Sub