受信メールの宛先や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をアドレス帳の名前に置き換えるマクロ」への2件のフィードバック

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

  2. はじめまして。
    こちらのマクロに大変助けていただいています。

    過去ログなどから、自分の望むようになんとか近づいているのですが、ひとつわからないことがあります。

    実行したいことは、受信したメールと、ルール付けでフォルダ分けした受信メールをアドレス帳の名前に置き換えなのですが、そこでひとつだけ、困っているのがフォルダ分けしたアドレスの反映がされていないことです。

    #マクロのモジュールがあまり理解できておらず、自分なりに色々組み合わせています
    #わかっていないことが悪いので、振り分け時に置き換えがされていなくても手動で良いです

    便宜上、連絡先にカテゴリAのアドレス、他はフォルダを作ってB、C・・・とし、DにはA~Cから選択したアドレスの組み合わせでグループ分けをしています。
    メール作成時に、デフォルトでカテゴリAにB,Cが入っていると大変不便なことが理由です。

    以下のようにしているのですが、これだとAに入っているアドレスには置き換えがされるのですが、B,Cに入っているアドレスは反映がされません。
    簡単なことかもしれませんが、手助けいただけるととてもうれしいです。

    ‘ メール受信時に発生するイベント
    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
    strSenderAddress = objMail.SenderEmailAddress
    Set objContact = FindContactByAddress(strSenderAddress)
    If Not objContact Is Nothing Then
    objMail.SentOnBehalfOfName = objContact.FullName
    objMail.Save
    End If
    End If
    End Sub

    ‘現在表示中のフォルダーの差出人を書き換えることができます。
    Public Sub 現在表示中のフォルダーの差出人を書き換え()
    On Error Resume Next
    Dim objMail ‘As MailItem

    For Each objMail In Application.ActiveExplorer.CurrentFolder.Items
    RewriteSender objMail.EntryID
    Next
    End Sub

    ‘ PF 連絡先を検索する関数
    Private Function FindContactByAddress(strAddress As String)
    Dim objContacts As Folder
    Dim objContact As ContactItem

    Set objContacts = Application.Session.Folders(“パブリック フォルダ”).Folders(“すべてのパブリック フォルダ”).Folders(“連絡先”)
    ‘ Outlook 2010 は下記を使用、sample@example.com を自分のメールアドレスに置き換える
    ‘Set objContacts = Application.Session.Folders(“パブリック フォルダー – sample@example.com“).Folders(“すべてのパブリック フォルダー”).Folders(“連絡先”)
    Set FindContactByAddress = FindContactRecursive(objContacts, strAddress)
    End Function

    ‘ 連絡先フォルダーを再帰的に検索する関数
    Private Function FindContactRecursive(objContacts As Folder, strAddress As String)
    Dim objSubFolder As Folder
    Set objContact = objContacts.Items.Find(“[Email1Address] = ‘” & strAddress _
    & “‘ or [Email2Address] = ‘” & strAddress _
    & “‘ or [Email3Address] = ‘” & strAddress & “‘”)
    ‘ 見つからなければサブフォルダーを検索
    If objContact Is Nothing Then
    For Each objSubFolder In objContacts.Folders
    ‘ 再帰的に検索
    Set objContact = FindContactRecursive(objSubFolder, strAddress)
    If Not objContact Is Nothing Then
    ‘ 見つかったら検索終了
    Set FindContactRecursive = objContact
    Exit Function
    End If
    Next
    End If
    Set FindContactRecursive = objContact
    End Function

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中