受信メールの宛先やCcをアドレス帳の名前に置き換えるマクロ


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


初めまして。
windows10でoutlook2013を使用しています。
相手からのメールを受け取った際に、複数に送られている宛先がアドレスのみで表示されているのを
アドレス帳の名前で分かるようにしたいのですが、マクロで出来ますか?
よろしくお願い致します。


以下のようなマクロで実現できます。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    On Error Resume Next
    Dim objItem 'As MailItem
    Dim objRec As Recipient
    Dim recType As OlMailRecipientType
    Dim fldContacts As Folder
    Dim objContact As ContactItem
    Dim strAddress As String
    Dim strContact As String
    Dim cRec As Integer
    Dim i As Integer
    ' 受信メールを取得
    Set objItem = Session.GetItemFromID(EntryIDCollection)
    ' 連絡先フォルダーを取得
    Set objContacts = Session.GetDefaultFolder(olFolderContacts)
    ' 受信時の受信者数を取得
    cRec = objItem.Recipients.Count
    For i = 1 To cRec
        ' 受信者オブジェクトを取得
        Set objRec = objItem.Recipients(i)
        strAddress = objRec.Address
        ' アドレスにより連絡先フォルダーを検索
        Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
            & "' or [Email2Address] = '" & strAddress _
            & "' or [Email3Address] = '" & strAddress & "'")
        If Not objContact Is Nothing Then
            ' 連絡先アイテムが見つかったらアドレスに対応する表示名を取得
            With objContact
                If .Email1Address = strAddress Then
                    strContact = .Email1DisplayName
                End If
                If .Email2Address = strAddress Then
                    strContact = .Email2DisplayName
                End If
                If .Email3Address = strAddress Then
                    strContact = .Email3DisplayName
                End If
            End With
            If InStr(strContact, strAddress) = 0 Then
                ' 表示名にアドレスが含まれていなければ追加
                strContact = strContact & "<" & strAddress & ">"
            End If
        Else
            ' 連絡先アイテムが見つからなければ元の表示名のまま追加
            If InStr(objRec.Name, objRec.Address) = 0 Then
                ' 表示名にアドレスが含まれていなければ追加
                strContact = objRec.Name & "<" & strAddress & ">"
            Else
                strContact = objRec.Name
            End If
        End If
        ' To か Cc かを保存しておく
        recType = objRec.Type
        ' 解決した名前で追加
        Set objRec = objItem.Recipients.Add(strContact)
        objRec.Type = recType
        objRec.Resolve
    Next
    ' 元の受信者は削除
    For i = cRec To 1 Step -1
        objItem.Recipients(i).Delete
    Next
    objItem.Save
End Sub

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

広告

受信メールの宛先やCcをアドレス帳の名前に置き換えるマクロ」への1件のフィードバック

  1. はじめまして、outlookを使い始めたばかりの初心者です。
    上記マクロを使ってみたくてoutlookの標準モジュールに貼り付けしてみたのですがマクロが認識されません。
    貼り付ける場所が違っているのでしょうか?

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中