使用Excel VBA的Outlook 2010 GAL

Question

我有以下代码从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

Answer 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