复制包括“外部联系人”的全局地址列表联系人

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