Outlookの連絡帳から指定した部署のメールアドレスを取得する。

Sub ImportMultipleDepartmentsFromGAL()
    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 rsAddress As DAO.Recordset
    Dim DepartmentNames As Variant
    Dim EmployeeName As String
    Dim EmailAddress As String
    Dim DepartmentName As String
    Dim i As Integer
    Dim DepartmentMatched As Boolean

    On Error GoTo ErrorHandler

    ' 指定したい部署名を配列で設定
    DepartmentNames = Array("営業部", "マーケティング部", "開発部")  ' ここに取得したい部署名を追加

    ' Outlookアプリケーションへの参照を取得
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olAddressList = olNamespace.AddressLists("グローバル アドレス一覧")  ' 環境によっては "Global Address List"

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

    ' アドレス取得テーブルへの接続
    Set db = CurrentDb()
    Set rsAddress = db.OpenRecordset("アドレス取得テーブル", dbOpenDynaset)

    ' アドレス取得テーブルをクリア（必要に応じて）
    DoCmd.SetWarnings False
    DoCmd.RunSQL "DELETE * FROM アドレス取得テーブル"
    DoCmd.SetWarnings True

    ' アドレスエントリをループ
    For Each olAddressEntry In olAddressEntries
        ' Exchangeユーザーか確認
        If olAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
            Set olExchangeUser = olAddressEntry.GetExchangeUser
            If Not olExchangeUser Is Nothing Then
                DepartmentMatched = False
                ' 部署名をループして一致するか確認
                For i = LBound(DepartmentNames) To UBound(DepartmentNames)
                    DepartmentName = DepartmentNames(i)
                    If Trim(UCase(olExchangeUser.Department)) = Trim(UCase(DepartmentName)) Then
                        DepartmentMatched = True
                        Exit For  ' 一致したらループを抜ける
                    End If
                Next i

                ' 部署が一致した場合、データを取得
                If DepartmentMatched Then
                    ' 名前とメールアドレスを取得
                    EmployeeName = olExchangeUser.Name
                    EmailAddress = olExchangeUser.PrimarySmtpAddress

                    ' アドレス取得テーブルに追加
                    rsAddress.AddNew
                    rsAddress!社員名 = EmployeeName
                    rsAddress!メールアドレス = EmailAddress
                    rsAddress.Update
                End If
            End If
        End If
    Next olAddressEntry

    MsgBox "指定した部署のメンバーの取得が完了しました。"

    ' オブジェクトの解放
    rsAddress.Close
    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

Sub ImportDepartmentMembersFromAD()
    Dim adoConnection As Object
    Dim adoCommand As Object
    Dim adoRecordset As Object
    Dim strLDAP As String
    Dim strQuery As String
    Dim DepartmentNames As Variant
    Dim DepartmentFilter As String
    Dim db As DAO.Database
    Dim rsAddress As DAO.Recordset
    Dim EmployeeName As String
    Dim EmailAddress As String
    Dim i As Integer

    On Error GoTo ErrorHandler

    ' 指定したい部署名を配列で設定
    DepartmentNames = Array("営業部", "マーケティング部", "開発部")  ' ここに取得したい部署名を追加

    ' 部署名からLDAPフィルタを作成
    DepartmentFilter = ""
    For i = LBound(DepartmentNames) To UBound(DepartmentNames)
        If DepartmentFilter <> "" Then
            DepartmentFilter = DepartmentFilter & "||"
        End If
        DepartmentFilter = DepartmentFilter & "(department=" & DepartmentNames(i) & ")"
    Next i
    DepartmentFilter = "(&(|" & DepartmentFilter & ")(mail=*))"  ' メールアドレスが存在するユーザーのみ

    ' LDAP接続文字列
    strLDAP = strLDAP = "LDAP://" & GetObject("LDAP://rootDSE").Get("defaultNamingContext")' ここを適切なドメインコントローラーに変更

    ' LDAPクエリ
    strQuery = DepartmentFilter

    ' ADO接続の作成
    Set adoConnection = CreateObject("ADODB.Connection")
    Set adoCommand = CreateObject("ADODB.Command")
    adoConnection.Provider = "ADsDSOObject"
    adoConnection.Open "Active Directory Provider"
    Set adoCommand.ActiveConnection = adoConnection

    ' クエリの設定
    adoCommand.CommandText = "<" & strLDAP & ">;" & strQuery & ";displayName,mail;subtree"

    ' レコードセットの取得
    Set adoRecordset = adoCommand.Execute

    ' アドレス取得テーブルへの接続
    Set db = CurrentDb()
    Set rsAddress = db.OpenRecordset("アドレス取得テーブル", dbOpenDynaset)

    ' アドレス取得テーブルをクリア（必要に応じて）
    DoCmd.SetWarnings False
    DoCmd.RunSQL "DELETE * FROM アドレス取得テーブル"
    DoCmd.SetWarnings True

    ' レコードセットをループ
    Do Until adoRecordset.EOF
        EmployeeName = adoRecordset.Fields("displayName").Value
        EmailAddress = adoRecordset.Fields("mail").Value

        ' データをテーブルに追加
        rsAddress.AddNew
        rsAddress!社員名 = EmployeeName
        rsAddress!メールアドレス = EmailAddress
        rsAddress.Update

        adoRecordset.MoveNext
    Loop

    MsgBox "指定した部署のメンバーの取得が完了しました。"

    ' オブジェクトの解放
    adoRecordset.Close
    adoConnection.Close
    Set rsAddress = Nothing
    Set db = Nothing
    Set adoRecordset = Nothing
    Set adoCommand = Nothing
    Set adoConnection = Nothing
    Exit Sub

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

Sub TestLDAPConnection()
    Dim adoConnection As Object
    Dim adoCommand As Object
    Dim adoRecordset As Object
    Dim strLDAP As String
    Dim strQuery As String

    On Error GoTo ErrorHandler

    ' LDAP接続文字列
    strLDAP = "LDAP://" & GetObject("LDAP://rootDSE").Get("defaultNamingContext")

    ' LDAPクエリ（全ユーザーを取得する簡単なフィルタ）
    strQuery = "(&(objectClass=user)(objectCategory=person))"

    ' ADO接続の作成
    Set adoConnection = CreateObject("ADODB.Connection")
    Set adoCommand = CreateObject("ADODB.Command")
    adoConnection.Provider = "ADsDSOObject"
    adoConnection.Open "Active Directory Provider"
    Set adoCommand.ActiveConnection = adoConnection

    ' クエリの設定
    adoCommand.CommandText = "<" & strLDAP & ">;" & strQuery & ";distinguishedName;subtree"

    ' レコードセットの取得
    Set adoRecordset = adoCommand.Execute

    ' レコードが取得できたか確認
    If Not adoRecordset.EOF Then
        MsgBox "LDAP接続に成功しました。"
    Else
        MsgBox "LDAP接続は成功しましたが、レコードが見つかりませんでした。"
    End If

    ' オブジェクトの解放
    adoRecordset.Close
    adoConnection.Close
    Set adoRecordset = Nothing
    Set adoCommand = Nothing
    Set adoConnection = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description & " (エラー番号: " & Err.Number & ")"
End Sub