特定の連絡先から受信者のアドレスのエントリーを検索し、電子メール2のアドレスに置き換えて返信するマクロ


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


はじめまして、いつもこのサイトの内容に助けられております。

要望なのですが、メール返信時に特定の連絡先フォルダーを参照して、同じメールアドレスの連絡先の、電子メール2のアドレスに置き換えて返信ウィンドウを開くマクロを作成することは可能でしょうか。

よろしくお願いします。


以下のようなマクロで実現できます。
マクロ中の CONTACT_FOLDER_PATH には検索する連絡先フォルダーのパスを指定します。
例えば、user@example.com というアカウントの “連絡先” フォルダーの下の “取引先” というようなフォルダーの場合、通常は “user@example.com\連絡先\取引先” という文字列を指定します。
なお、場合によっては “個人用 Outlook データ ファイル\連絡先” のような場合もありますので、正確なパスはフォルダー一覧を表示して確認してください。

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

Public Sub ReplyWithSecondAddress()
     Dim curItem As MailItem
     Dim repItem As MailItem
     Dim i As Integer
     Dim oneRecip As Recipient
     Dim newAddress As String
     Dim newRecip As Recipient
     '
     If TypeName(ActiveWindow) = "Inspector" Then
         Set curItem = ActiveInspector.CurrentItem
     Else
         Set curItem = ActiveExplorer.Selection(1)
     End If
     Set repItem = curItem.ReplyAll
     '
     For i = repItem.Recipients.Count To 1 Step -1
         Set oneRecip = repItem.Recipients(i)
         ' 電子メール 2 を検索
         newAddress = FindSecondAddress(oneRecip.AddressEntry)
         ' 電子メール 2 が見つかったら置き換え
         If newAddress <> "" Then
             Set newRecip = repItem.Recipients.Add(newAddress)
             newRecip.Type = oneRecip.Type
             oneRecip.Delete
         End If
     Next
     '
     repItem.Recipients.ResolveAll
     repItem.Display
End Sub
'
' 特定のフォルダーから連絡先を検索し、電子メール 2 のアドレスを返す関数
'
Private Function FindSecondAddress(addrEntry As AddressEntry) As String
     ' 検索する連絡先フォルダーのパスを指定
     Const CONTACT_FOLDER_PATH = "メールアドレス\連絡先\テスト"
     Dim arrPath As Variant
     Dim i As Integer
     Dim fldContact As Folder
     Dim objContact As ContactItem
     Dim newAddress As String
     ' 連絡先フォルダーを検索
     arrPath = Split(CONTACT_FOLDER_PATH, "\")
     Set fldContact = Session.Folders(arrPath(0))
     For i = 1 To UBound(arrPath)
         Set fldContact = fldContact.Folders(arrPath(i))
     Next
     ' 電子メール 1 のアドレスを検索
     Set objContact = fldContact.Items.Find("[Email1Address] = '" & addrEntry.Address & "'")
     If Not objContact Is Nothing Then
         With objContact
             ' 連絡先が見つかったら電子メール 2 のアドレスを確認
             If .Email2Address <> "" Then
                 ' 電子メール 2 が設定されていたら戻り値として設定
                 If InStr(.Email2DisplayName, .Email2Address) > 0 Then
                     newAddress = .Email2DisplayName
                 Else
                     newAddress = .Email2DisplayName & " <" & .Email2Address & ">"
                 End If
             End If
         End With
     Else
         newAddress = ""
     End If
     FindSecondAddress = newAddress
End Function

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中