带有 Excel VBA 的 Outlook 2010 GAL答案

【问题标题】：Outlook 2010 GAL with Excel VBA带有 Excel VBA 的 Outlook 2010 GAL
【发布时间】：2013-08-23 14:38:50
【问题描述】：

我有以下代码可以从 Excel 中获取 Outlook 中的联系人：

Public Sub GetGAL()

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.Items
Dim olContact As Outlook.ContactItem

Set olApp = CreateObject("Outlook.Application.14")
Set olNs = olApp.GetNamespace("MAPI")

Set olFldr = olNs.GetDefaultFolder(olFolderContacts).Items

For Each olContact In olFldr

Debug.Print olContact.FullName

Next olContact

End
End Sub

这行显示类型不匹配失败：

For Each olContact In olFldr

有人知道这是为什么吗？

另外，我如何访问 GAL 而不仅仅是我自己的联系人？

感谢您的帮助。

编辑：这是我访问 addressEntry 和 ExchangeUser 的新代码，但还不是国家/地区字段：

Option Explicit

Public Sub GetGAL()

Application.ScreenUpdating = False

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olGAL As Outlook.addressEntries
Dim olAddressEntry As Outlook.addressEntry

Dim olUser As Outlook.ExchangeUser

Dim i As Long

'Dim sTemp As String

'Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)

Set olApp = CreateObject("Outlook.Application.14")
Set olNs = olApp.GetNamespace("MAPI")

Set olGAL = olNs.addressLists("Global Address List").addressEntries

'On Error Resume Next

For i = 1 To olGAL.Count

Set olAddressEntry = olGAL.Item(i)

If olAddressEntry.DisplayType = olRemoteUser Then

Set olUser = olAddressEntry.GetExchangeUser

'Debug.Print olUser.Name & ";" & olUser.StateOrProvince
'Debug.Print sTemp

'ws.Cells(i, 1) = olUser.Name
'ws.Cells(i, 2) = olUser.StateOrProvince

End If

Next i

End

Application.ScreenUpdating = True
End Sub

【问题讨论】：

感谢tigeravatar，效果很好。感谢您的帮助。

标签： vba excel outlook

【解决方案1】：

试试这个。虽然如果您的 GAL 中有大量条目，则需要一段时间才能完成，并且您可能需要增加 65000 个。

Sub tgr()

    Dim appOL As Object
    Dim oGAL As Object
    Dim oContact As Object
    Dim oUser As Object
    Dim arrUsers(1 To 65000, 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

【讨论】：