Globale AdressListe in Excel auslesen

Sub GAL()
Dim oOutlook As Object
Dim appOL As Object
Dim oGAL As Object
Dim oContact As Object
Dim oUser As Object
Dim addrEintraege As Object
Dim i As Long
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
If Err.Number = 0 Then 'Tests if Outlook is started
MsgBox ("Bitte schließen Sie Outlook!")
Else
Set appOL = CreateObject("Outlook.Application")
Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Globale Adressliste"). _
AddressEntries
Application.DisplayAlerts = False
For i = 1 To oGAL.Count
Set oContact = oGAL.Item(i)
Select Case oContact.AddressEntryUserType
Case 0  'olExchangeRemoteUserAddressEntry
Set oUser = oContact.GetExchangeUser
Debug.Print oUser.LastName
Debug.Print oUser.FirstName
Debug.Print oUser.PrimarySmtpAddress
Debug.Print oUser.BusinessTelephoneNumber
'usw
Set oUser = Nothing
Case 1  'olExchangeDistributionListAddressEntry
Set oUser = oContact.GetExchangeDistributionList()
Set addrEintraege = oUser.GetExchangeDistributionListMembers()
Debug.Print oUser.Name
If Not (addrEintraege Is Nothing) Then
For Each exchMitglied In addrEintraege
Debug.Print (exchMitglied.Name)
Next
End If
Case 2  'olExchangePublicFolderAddressEntry
Set oUser = oContact.GetGlobalAddressList '="Nothing"
Debug.Print oContact.Name       'der Name ist ok
Debug.Print oContact.Address    'die Address ist eine Exchange Adresse
Case 3  'olExchangeAgentAddressEntry
Case 4  'olExchangeOrganizationAddressEntry
Case 5  'olExchangeRemoteUserAddressEntry
Set oUser = oContact.GetExchangeUser
Debug.Print oUser.LastName
Debug.Print oUser.FirstName
Debug.Print oUser.PrimarySmtpAddress
Debug.Print oUser.BusinessTelephoneNumber
'usw
Case 10 'olOutlookContactAddressEntry
Case 11 'olOutlookDistributionListAddressEntry
Case 20 'olLdapAddressEntry
Case 30 'olSmtpAddressEntry
Case 40 'olOtherAddressEntry
Case Else
Stop
End Select
Next i
Set appOL = Nothing
Set oGAL = Nothing
Set oContact = Nothing
Set oUser = Nothing
Set addrEintraege = Nothing
Err.Clear
End If
End Sub