複製包括「外部聯繫人」的全局地址列表聯繫人

Question

我有一個VBA代碼來從Outlook 2013中獲取整個全局地址列表，並將值Name和置於Excel工作表中。

問題是它只是從我的SMTP返回電子郵件/用戶（我猜）。

在此圖像中，我們可以從SMTP看到用戶像我全身都是黑色的，並覆蓋紅色的外部用戶。我的代碼：

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 

所以，我做錯了什麼？

Answer 1

根據this documentation,oContact.AddressEntryUserType的值應該包括olExchangeRemoteUserAddressEntry（5）對於外部用戶。

是什麼在你的代碼只是列出的Exchange用戶，所以它也跳過已啓用郵件的PublicFolders，通訊組列表等

---

編輯
找到一個更好的方法來提取姓名和電子郵件地址（如果有的話）：
參考： 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