带有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的新代码，但还没有访问country字段：

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

Answer 2

您的代码假定文件夹中只能有ContactItem对象。如果你遇到一个DistListItem类型的对象，它就会崩溃。

将item变量声明为泛型对象，然后检查type属性或使用TypeName函数确定确切的item类型。

编辑: PR_BUSINESS_ADDRESS_COUNTRY DASL名称为

http://schemas.microsoft.com/mapi/proptag/0x3A26001F 

对于地址条目，您可以在OutlookSpy中看到DALS属性名称。例如，您可以单击IMAPISession按钮，单击QueryIdentity，选择一个属性，查看DASL编辑框。