LDAP サーバーから差出人の表示名を取得して置き換えるマクロ


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


社内で使用している Outlook 2003 で、受信した時に社内の LDAP サーバーを参照して、差出人を LDAP の表示名に振り替えるマクロを探しています。
「メッセージの差出人を連絡先の表示名に置き換え、さらに連絡先ごとのフォルダに振り分けるマクロ」
「Outlook 2003 で受信者の詳細な情報をグローバル アドレス帳から取得するマクロ 」
あたりを組み合わせればできるかと試したのですが、うまく動きません。
サンプルとなるマクロを教えていただきたくお願いいたします。
環境
クライアントは Outlook 2003
LDAP は、アドレス帳にて表示可能(連絡先には取り込んでいない)
LDAP は社内にあり、AD にて構成されている。


残念ながら、Outlook のオブジェクト モデルでは LDAP アドレス帳のエントリーの情報は取得できません。
しかし、Active Directory の DC を LDAP として使用しており、そのドメインのユーザーで Outlook を実行しているということであれば、ADSI によりアドレス情報の取得は可能です。
以下は、ADSI で差出人の表示名を検索し、置き換えるマクロです。メッセージの受信時に実行されますが、すでに受信したメールに対して実行したい場合は、フォルダーを表示して RewriteSenderInCurrentFolder を実行してください。

' ここをトリプルクリックでマクロ全体を選択できます。
' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim i As Integer
    Dim c As Integer
    Dim colID As Variant
    If InStr(EntryIDCollection, ",") = 0 Then
        RewriteSender EntryIDCollection
    Else
        colID = Split(EntryIDCollection, ",")
        For i = LBound(colID) To UBound(colID)
            RewriteSender colID(i)
        Next
    End If
End Sub
'
' 差出人の名前を置き換えるサブプロシージャ
Private Sub RewriteSender(ByVal strEntryID As String)
    'On Error Resume Next
    Dim objMail 'As MailItem
    Dim objContact As ContactItem
    Dim strSenderAddress As String
    '
    Set objMail = Application.Session.GetItemFromID(strEntryID)
    If objMail.MessageClass = "IPM.Note" Then
        RewriteSenderByADSI objMail
    End If
End Sub
'
' 現在表示しているフォルダーのメールの差出人を置き換えるサブプロシージャ
Public Sub RewriteSenderInCurrentFolder()
    Dim objMail 'as MailItem
    For Each objMail In ActiveExplorer.CurrentFolder.Items
        If objMail.MessageClass = "IPM.Note" Then
            RewriteSenderByADSI objMail
        End If
    Next
End Sub
'
' ADSI で受信者の情報を取得するサブプロシージャ
Private Sub RewriteSenderByADSI(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
    '
    strQuery = "(|mail=" & Item.SenderEmailAddress & ")"
    strQuery = "<LDAP://" & DOMAIN & ">;" & strQuery & ";displayName;subtree"
    '
    oCommand.CommandText = strQuery
    Set oRecordset = oCommand.Execute
    '
    If Not oRecordset.EOF Then
        Item.SentOnBehalfOfName = oRecordset.fields("displayName").Value
        Item.Save
    End If
    '
    oConnection.Close
    Set oRecordset = Nothing
    Set oConnection = Nothing
End Sub

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

広告

LDAP サーバーから差出人の表示名を取得して置き換えるマクロ」への2件のフィードバック

  1. 早速実行してみたところ、期待通りの動きをしてくれました。ありがとうございました。
    このマクロを社内ユーザー250名ほどに配布したいのですが、自動もしくは、クリック程度でセットアップする方法はないでしょうか?次から次へとお願いばかりで恐縮ですが、お知恵をお借りしたいと思います。

    • 残念ながらマクロを簡単に配布する方法はありません。
      多数のユーザーに配布するのであれば、マクロではなくアドインとして実装する必要があり、そのためには Visual Studio のような開発環境が必要です。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中