[[20210317085215]]　『outlook（Exchange）のグローバルアドレス一覧かａx（F@NKS）　ページの最後に飛ぶ

『outlook（Exchange）のグローバルアドレス一覧から自宅電話を取得したい』（F@NKS）

ExchangeUser オブジェクトから自宅電話を取得したいと思うのですが、項目が無い？？どこに格納されているのでしょうか？

Option Explicit

    Dim x As Integer
    Dim OutlookObj As Outlook.Application
    Dim AddressListObj As Outlook.AddressList
    Dim AddressEntryObj As Outlook.addressEntry
    Dim ExchangeUserObj As Outlook.ExchangeUser

Sub ボタン1_Click()

    Application.ScreenUpdating = False

    Set OutlookObj = CreateObject("Outlook.Application")
    Set AddressListObj = OutlookObj.Session.AddressLists("ALL users")

    With Sheets("Global")
        .Range("A1").CurrentRegion.Clear
        .Cells(1, 1) = "LastName" '姓
        .Cells(1, 2) = "FirstName" '名
        .Cells(1, 3) = "CompanyName" '勤務先
        .Cells(1, 4) = "Department" '部署
        .Cells(1, 5) = "JobTitle" '役職
        .Cells(1, 6) = "FullName" '表題
        .Cells(1, 7) = "Email1Address" '電子メール
        .Cells(1, 8) = "Email1DisplayName" '表示名
        .Cells(1, 9) = "BusinessTelephoneNumber" '勤務先電話
        .Cells(1, 10) = "HomeTelephoneNumber" '自宅電話
        .Cells(1, 11) = "MobileTelephoneNumber" '携帯電話
        With .Range("A1:Z1")
            .Font.Bold = True
            .Font.ColorIndex = 10
            .Font.Size = 11
        End With
    End With

    x = 1

    For Each AddressEntryObj In AddressListObj.AddressEntries

        Set ExchangeUserObj = AddressEntryObj.GetExchangeUser

        If ExchangeUserObj.FirstName = "" And ExchangeUserObj.LastName = "" Then
            '何もしない
        Else
            If ExchangeUserObj.Department = "業務用アカウント" Then
                '何もしない
            Else
                x = x + 1
                Application.StatusBar = "Processing no. " & x & " ... "

                With Sheets("Global")
                    .Cells(x, 1) = ExchangeUserObj.LastName '姓
                    .Cells(x, 2) = ExchangeUserObj.FirstName '名
                    .Cells(x, 3) = ExchangeUserObj.CompanyName '勤務先
                    .Cells(x, 4) = ExchangeUserObj.Department '部署
                    .Cells(x, 5) = ExchangeUserObj.JobTitle '役職
                    .Cells(x, 6) = ExchangeUserObj.LastName & " " & ExchangeUserObj.FirstName '表題
                    .Cells(x, 7) = ExchangeUserObj.PrimarySmtpAddress '電子メール
                    .Cells(x, 8) = ExchangeUserObj.Name & " (" & ExchangeUserObj.PrimarySmtpAddress & ")" '表示名
                    .Cells(x, 9) = ExchangeUserObj.BusinessTelephoneNumber '勤務先電話
                    .Cells(x, 10) = "" '自宅電話
                    .Cells(x, 11) = ExchangeUserObj.MobileTelephoneNumber '携帯電話
               End With
            End If
        End If

        DoEvents
    Next AddressEntryObj

    Application.ScreenUpdating = True

    MsgBox "Outlookのインポートが完了しました！", vbInformation

End Sub

＜使用 Excel：Excel2010、使用 OS：Windows10 ＞

回答者の参考に。
同一質問がありました。
https://www.moug.net/faq/viewtopic.php?t=80328
（参考情報） 2021/03/17(水) 09:16

 ついでに。

https://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=193481&rev=0
（マルチネス） 2021/03/17(水) 09:43

コメント返信：

[ 一覧(最新更新順) ]

[[20210317085215]] 『outlook（Exchange）のグローバルアドレス一覧かａx（F@NKS） ページの最後に飛ぶ

[[20210317085215]]　『outlook（Exchange）のグローバルアドレス一覧かａx（F@NKS）　ページの最後に飛ぶ