OutlookからAccessの社員テーブルに存在する社員のメールアドレスを取得する

Sub GetEmailAddressesFromOrganization()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olAddressList As Outlook.AddressList
    Dim olAddressEntries As Outlook.AddressEntries
    Dim olAddressEntry As Outlook.AddressEntry
    Dim olExchangeUser As Outlook.ExchangeUser
    Dim db As DAO.Database
    Dim rsEmployee As DAO.Recordset
    Dim rsAddress As DAO.Recordset
    Dim EmployeeName As String
    Dim EmailAddress As String
    Dim FoundContact As Boolean
    Dim TargetDepartment As String

    On Error GoTo ErrorHandler

    ' 絞り込みたい組織名を設定
    TargetDepartment = "営業部"  ' ここを目的の組織名に変更

    ' Outlookアプリケーションへの参照を取得
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olAddressList = olNamespace.AddressLists("グローバル アドレス一覧") ' または適切なアドレスリスト名

    ' アドレスリストのエントリを取得
    Set olAddressEntries = olAddressList.AddressEntries

    ' データベースとレコードセットを開く
    Set db = CurrentDb()
    Set rsEmployee = db.OpenRecordset("SELECT * FROM 社員テーブル")
    Set rsAddress = db.OpenRecordset("アドレス取得テーブル", dbOpenDynaset)

    ' 社員テーブルをループ
    Do While Not rsEmployee.EOF
        EmployeeName = rsEmployee!社員名  ' フィールド名を適宜修正
        EmailAddress = ""
        FoundContact = False

        ' アドレスエントリをループ
        For Each olAddressEntry In olAddressEntries
            ' Exchangeユーザーか確認
            If olAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olExchangeUser = olAddressEntry.GetExchangeUser
                If Not olExchangeUser Is Nothing Then
                    ' 部署名でフィルタリング
                    If olExchangeUser.Department = TargetDepartment Then
                        ' 社員名と一致するか確認
                        If olExchangeUser.Name = EmployeeName Then
                            EmailAddress = olExchangeUser.PrimarySmtpAddress
                            FoundContact = True
                            Exit For
                        End If
                    End If
                End If
            End If
        Next olAddressEntry

        ' 一致する連絡先があれば、アドレス取得テーブルに追加
        If FoundContact Then
            rsAddress.AddNew
            rsAddress!社員名 = EmployeeName
            rsAddress!メールアドレス = EmailAddress
            rsAddress.Update
        End If

        rsEmployee.MoveNext
    Loop

    MsgBox "メールアドレスの取得が完了しました。"

    ' オブジェクトの解放
    rsEmployee.Close
    rsAddress.Close
    Set rsEmployee = Nothing
    Set rsAddress = Nothing
    Set db = Nothing
    Set olExchangeUser = Nothing
    Set olAddressEntries = Nothing
    Set olAddressList = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description
End Sub