Outlook 2010 GAL with Excel VBA

Question

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?

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

Thanks for any help.

Edit: 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

Answer 1

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