Globales Outlook Adressbuch Suchfilter

Private Const olExchangeGlobalAddressList As Integer = 1
Private Const olExchangeUserAddressEntry As Integer = 0
Private Const olExchangeRemoteUserAddressEntry As Integer = 5
Public Sub readGAL()
Dim oOutlook As Object
Dim oAddressList As Object
Dim oAddressEntry As Object
Dim oExchangeUser As Object
i = 1
Application.ScreenUpdating = False
Set oOutlook = CreateObject("Outlook.Application")
For Each oAddressList In oOutlook.Session.AddressLists
If oAddressList.AddressListType = olExchangeGlobalAddressList Then
For Each oAddressEntry In oAddressList.AddressEntries
If oAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Or oAddressEntry. _
AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
Set oExchangeUser = oAddressEntry.GetExchangeUser
Cells(i, 1).Value = oExchangeUser.Name
Cells(i, 2).Value = oExchangeUser.Department
Cells(i, 3).Value = oExchangeUser.CompanyName
Cells(i, 4).Value = oExchangeUser.Alias
Cells(i, 5).Value = oExchangeUser.Type
Cells(i, 6).Value = oExchangeUser.PrimarySmtpAddress
Application.StatusBar = i
End If
i = i + 1
Next
End If
Next
Application.ScreenUpdating = True
Set oExchangeUser = Nothing
Set oAddressEntry = Nothing
Set oAddressList = Nothing
Set oOutlook = Nothing
End Sub