vba - 复制全局地址列表联系人，包括 "External Contacts"

Question

我有一个 VBA 代码，用于从 Outlook 2013 获取整个全局地址列表，并将值 Name 和 E-mail Address 放入 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 用户，因此它还会跳过启用邮件的公共(public)文件夹、通讯组列表等。

<小时/> 编辑
找到了提取姓名和电子邮件地址(如果有)的更好方法:
引用: 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