Outlook 2003 で受信者の詳細な情報をグローバル アドレス帳から取得するマクロ


コメントにて以下のようなご要望をいただきました。


差出人名や宛先は 会社のExchangeServer(?)に登録されている アルファベット表記(表示名)で表示されます。
宛先が多人数だと、誰に送られていて、誰には送られていないのか、判別に苦労します。
1人1人の宛先のアルファベットをダブルクリック(あるいは右クリックでプロパティ表示)をすると プロパティ-全般 で、名前として 姓・名が表示されますが、この姓・名を取得し、表示する方法はないでしょうか?(検索先は「連絡先」ではありません。念のため。)
(姓・名だけでなく、部署や役職なども取得できると もっとうれしいです。)
よろしくお願いします。


Exchange Server 環境では Active Directory に格納されている情報をアドレス帳の詳細情報で表示することが可能ですが、Outlook 2003 の Outlook オブジェクト モデルではそのような情報にアクセスすることができません。
CDO や ADSI といった API を使用する必要があります。
ただし、それぞれ以下のような制限があるため、これらの制限を考慮してどちらを使用するか選択してください。
CDO: Exchange Server のパブリック フォルダのセキュリティ設定フォームを適切に設定しないと、アドレス帳のアクセスの際に警告が表示されます。
ADSI: Windows にログオンする際には Active Directory にアクセス可能なドメイン ユーザーとしてログオンする必要があります。

以下は CDO および ADSI で表示名、姓、名、部署、役職を取得するマクロのサンプルです。なお、取得可能な属性の ID や名前については、http://msdn.microsoft.com/ja-jp/library/cc400656.aspx を参照してください。

' ここをトリプルクリックでマクロ全体を選択できます。
'
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    ' CDO で取得する場合は、下記のコードを有効にする。
    'MsgBox "以下の受信者に送信されます。" & vbCrLf & FindUserByCDO(Item), vbInformation
    ' ADSI で取得する場合は、下記のコードを有効にする。
    'MsgBox "以下の受信者に送信されます。" & vbCrLf & FindUserByADSI(Item), vbInformation
End Sub
'
'    CDO で受信者の情報を取得する
'
Public Function FindUserByCDO(ByVal Item As MailItem)
    On Error Resume Next
    Const PR_DISPLAY_NAME = &H3001001E
    Const PR_SURNAME = &H3A11001E
    Const PR_GIVEN_NAME = &H3A06001E
    Const PR_DEPARTMENT_NAME = &H3A18001E
    Const PR_TITLE = &H3A17001E
    Dim objSession ' As MAPI.Session
    Dim objAddrEntry ' As MAPI.AddressEntry
    Dim objRecip As Recipient
    Dim strNames As String
    '
    Set objSession = CreateObject("MAPI.Session")
    objSession.Logon "", "", False, False
    strNames = ""
    For Each objRecip In Item.Recipients
        Set objAddrEntry = objSession.GetAddressEntry(objRecip.EntryID)
        If Not objAddrEntry Is Nothing Then
            strNames = strNames & objAddrEntry.fields(PR_DISPLAY_NAME).Value & " "
            strNames = strNames & objAddrEntry.fields(PR_SURNAME).Value & " "
            strNames = strNames & objAddrEntry.fields(PR_GIVEN_NAME).Value & " "
            strNames = strNames & objAddrEntry.fields(PR_DEPARTMENT_NAME).Value & " "
            strNames = strNames & objAddrEntry.fields(PR_TITLE)
            strNames = strNames & vbCrLf
        Else
            strNames = strNames & objRecip.Name & vbCrLf
        End If
    Next
    objSession.Logoff
    Set objSession = Nothing
    FindUserByCDO = strNames
End Function
'
'    ADSI で受信者の情報を取得する
'
Public Function FindUserByADSI(ByVal Item As MailItem)
    Const DOMAIN = "example.com" ' Active Directory のドメイン
    Dim i As Integer
    Dim oConnection
    Dim oCommand
    Dim oRecordset
    Dim objRecip As Recipient
    Dim strQuery As String
    Dim strNames As String
    '
    Set oConnection = CreateObject("ADODB.Connection")
    Set oCommand = CreateObject("ADODB.Command")
    oConnection.Provider = "ADsDSOObject"
    oConnection.Open "Active Directory Provider"
    Set oCommand.ActiveConnection = oConnection
    '
    For Each objRecip In Item.Recipients
        If objRecip.AddressEntry.Type = "EX" Then
            strQuery = "(|legacyExchangeDN=" & objRecip.Address & ")"
            strQuery = "<LDAP://" & DOMAIN & ">;" & strQuery & ";displayName,sn,givenName,department,title;subtree"
            '
            oCommand.CommandText = strQuery
            Set oRecordset = oCommand.Execute
           
            If Not oRecordset.EOF Then
                strNames = strNames & oRecordset.fields("displayName").Value & " " & _
                                      oRecordset.fields("sn").Value & " " & _
                                      oRecordset.fields("givenName").Value & " " & _
                                      oRecordset.fields("department").Value & " " & _
                                      oRecordset.fields("title").Value & vbCrLf
            Else
                strNames = strNames & objRecip.Name & vbCrLf
            End If
        Else
            strNames = strNames & objRecip.Name & vbCrLf
        End If
    Next
    oConnection.Close
    Set oRecordset = Nothing
    Set oConnection = Nothing
    FindUserByADSI = strNames
End Function

マクロの登録方法やメニューへの追加について

広告

Outlook 2003 で受信者の詳細な情報をグローバル アドレス帳から取得するマクロ」への1件のフィードバック

  1. ADSI で認証情報を追加する場合は、oConnection.Provider = “ADsDSOObject” と oConnection.Open “Active Directory Provider” の間に以下のように記述を追加します。

    oConnection.Provider = “ADsDSOObject”
    oConnection.Properties(“User ID”) = “domain\username” ‘ Exchange サーバーにログオンする際のドメイン名およびユーザー名
    oConnection.Properties(“Password”) = “password” ‘ Exchange サーバーにログオンする際のパスワード
    oConnection.Properties(“Encrypt Password”) = True
    oConnection.Properties(“ADSI Flag”) = 1
    oConnection.Open “Active Directory Provider”

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中