ExcelでOutlook GALをプルするスクリプト

Question

次のスクリプトを使用して、Excelのグローバルアドレス帳からプロジェクトに必要なフィールドを取得していますが、正常に機能していますが、次のスクリプトを含むフィールドを追加します。個人が座っている階数。誰もこのフィールドを追加する方法を知っていますか？ GetExchangeUserオブジェクトグループを使用して、すべてのフィールドを試しました。私にお知らせください！私は非常に感謝されます！！

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 

ありがとう!! レーシー

Answer 1

.OfficeLocationについて：:)フロア番号プロパティはありません。