返信メッセージで表示名を連絡先のものに置き換えるマクロ (Exchange 対応版)


返信メッセージで表示名をアドレス帳のものに置き換えるマクロ」について以下のようなご要望をいただきました。


はじめまして。今まですごく便利に使用させていただきましたが、会社のメールがExchangeとなり、offline global address listが参照されて、自分で登録したアドレス帳が反映しなくなりました。登録したアドレス帳で置き換え出来る対応は可能でしょうか?
よろしくお願いします。


元のマクロは Exchange 環境を考慮したものでなかったため、宛先に Exchange 組織の受信者が含まれる場合に Exchange のアドレスが表示されてしまい正しく動作しませんでした。
Exchange 環境に対応したマクロは以下のようになります。なお、Outlook 2003 以前のバージョンには対応していません。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ReplyWithAddressBookNameEx()
    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Dim objReply As MailItem
    Dim objRecip As Recipient
    Dim objContact As ContactItem
    Dim objAddrList As AddressList
    Dim i As Integer
    Dim objAddrEntry As AddressEntry
    Dim bFound As Boolean
    Dim cRecips As Integer
    Dim colAddress() As String
    Dim colName() As String
    Dim colType() As Integer
    '
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        Set objReply = ActiveInspector.CurrentItem.ReplyAll
    Else
        Set objReply = ActiveExplorer.Selection(1).ReplyAll
    End If 
    cRecips = objReply.Recipients.Count
    ReDim colAddress(cRecips) As String
    ReDim colName(cRecips) As String
    ReDim colType(cRecips) As Integer
    For i = cRecips To 1 Step -1
        Set objRecip = objReply.Recipients.Item(i)
        With objRecip.AddressEntry
            If .Type = "SMTP" Then
                colAddress(i) = objRecip.Address
            Else
                colAddress(i) = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
            End If
        End With
        colName(i) = objRecip.Name
        colType(i) = objRecip.Type
        objReply.Recipients.Remove i
    Next
    '
    For i = 1 To cRecips
        Set objRecip = Nothing
        For Each objAddrList In Session.AddressLists
            If objAddrList.AddressListType = olOutlookAddressList Then
                For Each objAddrEntry In objAddrList.AddressEntries
                    If objAddrEntry.Address = colAddress(i) Then
                        Set objRecip = objReply.Recipients.Add(colAddress(i))
                        Set objRecip.AddressEntry = objAddrEntry
                        objRecip.Type = colType(i)
                        Exit For
                    End If
                Next
                If Not objRecip Is Nothing Then
                    Exit For
                End If
            End If
        Next
        If objRecip Is Nothing Then
            Set objRecip = objReply.Recipients.Add(colName(i) & "<" & colAddress(i) & ">")
            objRecip.Type = colType(i)
        End If
    Next
    objReply.Recipients.ResolveAll
    objReply.Display
End Sub

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

広告

返信メッセージで表示名を連絡先のものに置き換えるマクロ (Exchange 対応版)」への3件のフィードバック

  1. こちらのマクロですが、何も実行されません。
    Visual Basic Editorで確認すると、オブジェクト変数またはWithブロック変数が設定されていません。
    とエラーが発生します。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中