Skript zum Ziehen von Outlook GAL in Excel

Question

Ich verwende das folgende Skript, um die Felder, die ich für ein Projekt aus dem globalen Adressbuch in Excel benötigen, ziehen, und es funktioniert ordnungsgemäß, aber ich möchte ein Feld hinzufügen, das enthält die Stockwerknummer, auf der eine Person sitzt. Kann jemand dieses Feld hinzufügen? Ich habe alle Felder mit der GetExchangeUser-Objektgruppe versucht. Lass es mich wissen, bitte! Ich wäre sehr dankbar!!

Sub GetOutlookAddressBook() 

' Need to add reference to Outlook 
'(In VBA editor Tools References MS Outlook #.# Library) 
' Adds addresses to existing Sheet called Address and 
' defines name Addresses containing this list 
' For use with data Validation ListBox (Source as =Addresses) 

On Error GoTo 0 

Dim objOutlook As Outlook.Application 
Dim objAddressList As Outlook.AddressList 
Dim objAddressEntry As Outlook.AddressEntry 
Dim lngCounter As Long 

Application.ScreenUpdating = False 

' Setup connection to Outlook application 
Set objOutlook = CreateObject("Outlook.Application") 
Set objAddressList = objOutlook.Session.AddressLists("Global Address List") 


Application.EnableEvents = False 
'Application.DisplayAlerts = False 

    ' Clear existing list 
Sheets("Address").Range("A:A").Clear 

    'Step through each contact and list each that has an email address 
For Each objAddressEntry In objAddressList.AddressEntries 
    If objAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then 
    lngCounter = lngCounter + 1 
    Application.StatusBar = "Address no. " & lngCounter & " ... " &    objAddressEntry.Address 
    Sheets("Address").Cells(lngCounter, 1) = objAddressEntry.GetExchangeUser.Alias 
    Sheets("Address").Cells(lngCounter, 2) = objAddressEntry.GetExchangeUser.Name 
    Sheets("Address").Cells(lngCounter, 3) = objAddressEntry.GetExchangeUser.CompanyName 
    Sheets("Address").Cells(lngCounter, 4) = objAddressEntry.GetExchangeUser.Address 
    Sheets("Address").Cells(lngCounter, 5) = objAddressEntry.GetExchangeUser.Department 
    Sheets("Address").Cells(lngCounter, 6) = objAddressEntry.GetExchangeUser.JobTitle 
    Sheets("Address").Cells(lngCounter, 7) = objAddressEntry.GetExchangeUser.OfficeLocation 
    DoEvents 
    End If 
Next objAddressEntry 

' Define range called "Addresses" to the list of emails 
'Sheets("Address").Cells(1, 1).Resize(lngCounter, 1).Name = "Addresses" 
    'error: 
Set objOutlook = Nothing 
Application.StatusBar = False 
Application.EnableEvents = False 


End Sub 

Danke !! Lacey

Answer 1

.OfficeLocation ist darüber :), gibt es keine Stockwerksnummer Eigenschaft.