コメントにて以下のご要望をいただきました。
はじめまして、いつもこのサイトの内容に助けられております。
要望なのですが、メール返信時に特定の連絡先フォルダーを参照して、同じメールアドレスの連絡先の、電子メール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
Outlook 研究所 