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

Question

我有一个 VBA 代码可以从 Outlook 2013 获取整个全局地址列表并将值 Name 和 E-mail Address 放在 Excel sheet 中.

问题是它只从我的 SMTP 返回 e-mails/users（我猜）。

在这张图片中，我们可以看到来自 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 用户，因此它还会跳过已启用邮件的公共文件夹、分发列表等。

编辑
找到了提取姓名和电子邮件地址（如果有）的更好方法：
参考：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

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

Copying Global Address List contacts including "External Contacts"

email

excel

outlook

vba

gal