受信メールの差出人を連絡先フォルダーのサブフォルダーも含めて検索し、表示名を置き換えるマクロ


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


Windows10、Outlook2016環境です。

受信したメール(受信時・すでに受信済の任意フォルダーにあるメール)の差出人を、アドレス帳にある表示名に置き換えて表示したく、いろいろ試してみたのですがうまくいかずお願いします。

おそらく、連絡先フォルダーをいくつかに仕分けていることが原因だと思われます。

連絡先フォルダーのディレクトリは以下のようになっています

連絡先フォルダー/
 ├ ***@**.****
 ├ ***@**.****
 ├ 連絡先フォルダーA/
 │ ├ ***@**.****
 │ ├ ***@**.****
 ├ 連絡先フォルダーB/
 │ ├ ***@**.****
 │ ├ ***@**.****
 └ 連絡先フォルダーC/
   ├ ***@**.****
   ├ ***@**.****

・受信時、連絡先フォルダーにアドレスが見つからなければ、A、B、C・・・から探し置き換え、なければそのまま表示する

・すでに受信してしまっているメールに対しても同様の処理を行う(手動で可)

同じ差出人でも件名によって振り分けルールを実行しているので、今回のVBA処理で
振り分けを行うことはありません。
  (できれば素晴らしいですが、今回はそこまで求めません)

簡単なことなのかと思うのですが、お願いできると大変助かります。


特定のフォルダーの下のサブフォルダーも検索するという場合、「再帰」という手法を使用します。
連絡先をマクロで活用するという記事のマクロをサブフォルダーに対応させるたマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

' メール受信時に発生するイベント
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 = FindContactByAddressIncludeSub(strSenderAddress)
         If Not objContact Is Nothing Then
             objMail.SentOnBehalfOfName = objContact.FileAs
             objMail.Save
         End If
     End If
End Sub
'
' 受信トレイの差出人の名前を置き換えるサブプロシージャ
Public Sub RewriteSenderInInbox()
     'On Error Resume Next
     Dim objMail 'As MailItem
     '
     For Each objMail In Application.Session.GetDefaultFolder(olFolderInbox).Items
         RewriteSender objMail.EntryID
     Next
End Sub
'
' アドレスから連絡先フォルダーの配下をすべて検索する関数
Private Function FindContactByAddressIncludeSub(strAddress As String) As ContactItem
     Dim fldContacts As Folder
     '
     Set fldContacts = Application.Session.GetDefaultFolder(olFolderContacts)
     Set FindContactByAddressIncludeSub = FindContactRecursive(fldContacts, strAddress)
End Function
'
' アドレス検索を再帰的に実行する関数
Private Function FindContactRecursive(fldContacts As Folder, strAddress As String) As ContactItem
     On Error Resume Next
     Dim objContact As ContactItem
     Dim fldSub As Folder
     Set objContact = fldContacts.Items.Find("[Email1Address] = '" & strAddress _
         & "' or [Email2Address] = '" & strAddress _
         & "' or [Email3Address] = '" & strAddress & "'")
     '
     If objContact Is Nothing Then
         ' 見つからなければサブフォルダーの検索
         For Each fldSub In fldContacts.Folders
             ' 再帰的に検索
             Set objContact = FindContactRecursive(fldSub, strAddress)
             If Not objContact Is Nothing Then
                 ' 見つかったらループ終了
                 Exit For
             End If
         Next
     End If
     '
     If objContact Is Nothing Then
         Set FindContactRecursive = Nothing
     Else
         Set FindContactRecursive = objContact
     End If
End Function

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

受信メールの差出人を連絡先フォルダーのサブフォルダーも含めて検索し、表示名を置き換えるマクロ」への2件のフィードバック

  1. ご対応いただきありがとうございます!さっそく試し、うまく動作しているようなのですが、「表示名」ではなく、「表題」を取得してしまいます。
    「表題」はアドレス帳を一覧する際にインデックスとして使用しているため、「表示名」を取得できれば良いのですが、どの部分を変更すれば良いでしょうか?

  2. すみません、自己解決できました!
    「連絡先をマクロで活用する」のレス内から答えが見つかりました。

    ‘ 差出人の名前を置き換えるサブプロシージャ内
    objMail.SentOnBehalfOfName = objContact.FileAs 
     
                 ↓

    objMail.SentOnBehalfOfName = objContact.FullName

    これで思い通りに作動しました。
    本当に助かりました、ありがとうございます。

コメントを残す

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

WordPress.com ロゴ

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

Google フォト

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

Twitter 画像

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

Facebook の写真

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

%s と連携中