带有 Excel VBA 的 Outlook 2010 GAL [英] Outlook 2010 GAL with Excel VBA

问题描述

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

I have the following code to get contacts out of Outlook from Excel:

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

这一行失败了，说类型不匹配:

It is failing on this line saying there is a type mismatch:

For Each olContact In olFldr

有人知道这是为什么吗?

Does anyone know why this is?

此外，我如何访问 GAL 而不是我自己的联系人?

Also, how do I access the GAL as opposed to just my own contacts?

感谢您的帮助.

这是我用于访问 addressEntry 和 ExchangeUser 的新代码，但还不是国家/地区字段:

Here's my new code to access the addressEntry and ExchangeUser, however, not the country field yet:

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

推荐答案

试试这个.尽管如果您的 GAL 中有大量条目，则需要一段时间才能完成，您可能需要增加 65000.

Give this a try. Although if you have tons and tons of entries in your GAL, it will take awhile to complete, and you may have to increase the 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

这篇关于带有 Excel VBA 的 Outlook 2010 GAL的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！