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

Question

我有一个VBA代码可以从Outlook 2013获取整个全局地址列表，并将值extension WidgetAPI.VagueWidget: Widget { var temperature: Float { return self.temperature } } 和Name放在Excel工作表中。

问题是它只从我的SMTP返回电子邮件/用户（我猜）。

在此图片中，我们可以看到SMTP中的用户被黑色覆盖，外部用户被红色覆盖。我的代码：

E-mail Address

那么，我做错了吗？

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