1

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

2 回答 2

8

试试这个。尽管如果您的 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
于 2013-08-23T15:48:52.487 回答
1

您的代码假定您只能在文件夹中有 ContactItem 对象。如果遇到 DistListItem 类型的对象，它将中断。

将 item 变量声明为通用 Object，然后检查 Type 属性或使用 TypeName 函数来确定确切的 item 类型。

编辑：PR_BUSINESS_ADDRESS_COUNTRY DASL 名称是

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

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

于 2013-08-23T16:15:33.200 回答