固定アドレスを追加して返信、転送をするマクロ


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


お世話になります。

返信、転送時
  宛先:Aさん、CC:Bさん、BCC:Cさんとするマクロをお願いできないでしょうか?
・宛先:Aさんは送信元の場合が多い
  ・CC:Bさん、BCC:Cさんは毎回固定

返信メッセージで表示名をアドレス帳のものに置き換えるマクロ
  こちらを先に実行し、次にCC:Bさん、BCC:Cさんを別のマクロ
  もしくは、全てを同時に可能なマクロ

環境
OS:Windows10 64bit
  Office365

よろしくお願いいたします。


まず、Outlook 自体の返信や転送の際に自動的に追加するようなマクロを作ろうとするとイベント処理が複雑になるので、返信や転送を行うマクロを作ってもともとの返信や転送の代わりに使用するようにします。
宛先や Cc などを追加するのであれば MailItem オブジェクトの Recipients プロパティの Add メソッドで受信者の表示名とアドレスを追加した後、そのメソッドで返される Recipient オブジェクトの Type に宛先や Cc の種別を設定します。
ただ、単に追加するだけだと、元の受信者や送信者のアドレスが重複する可能性があるので、すでに存在する場合は追加しないというロジックが必要になります。
なお、返信メッセージで表示名をアドレス帳のものに置き換えるマクロについては以前こちらで公開していますが、返信時に同時に実行するように組み込んでいます。

マクロは以下のようになります。
AddFixedAddress の中の TO_NAME や TO_ADDRESS などを宛先などで指定する受信者の表示名やアドレスに置き換えてください。
また、返信を行うときには ReplyWithFixedAddress、転送を行うときには ForwardWithFixedAddress を実行してください。

' ここをトリプルクリックでマクロ全体を選択できます。
'
' 固定アドレスを追加して返信するマクロ
Public Sub ReplyWithFixedAddress()
     Dim objReply As MailItem
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set objReply = ActiveInspector.CurrentItem.ReplyAll
     Else
         Set objReply = ActiveExplorer.Selection(1).ReplyAll
     End If
     ' 元のメールの受信者の表示名の置き換え
     ReplaceDisplayName objReply
     ' 固定アドレスの追加
     AddFixedAddress objReply
     objReply.Display
End Sub
'
' 固定アドレスを追加して転送するマクロ
Public Sub ForwardWithFixedAddress()
     Dim objForward As MailItem
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set objForward = ActiveInspector.CurrentItem.Forward
     Else
         Set objForward = ActiveExplorer.Selection(1).Forward
     End If
     ' 固定アドレスの追加
     AddFixedAddress objForward
     objForward.Display
End Sub
'
' 固定アドレスを追加するマクロ
Private Sub AddFixedAddress(objReFw As MailItem)
     Const TO_NAME = "UserTO"
     Const TO_ADDRESS = "userto@example.com"
     Const CC_NAME = "UserCC"
     Const CC_ADDRESS = "usercc@example.com"
     Const BCC_NAME = "UserBCC"
     Const BCC_ADDRESS = "userbcc@example.com"
     '
     AddIfNotExist objReFw, TO_NAME, TO_ADDRESS, olTo
     AddIfNotExist objReFw, CC_NAME, CC_ADDRESS, olCC
     AddIfNotExist objReFw, BCC_NAME, BCC_ADDRESS, olBCC
     objReFw.Recipients.ResolveAll
End Sub
'
' 受信者に含まれない場合だけ追加するマクロ
Private Sub AddIfNotExist(objReFw As MailItem, strName As String, strAddr As String, iType As OlMailRecipientType)
     Dim objRecip As Recipient
     ' メールの受信者すべてのアドレスをチェック
     For Each objRecip In objReFw.Recipients
         If objRecip.Address = strAddr Then
             ' 見つかったら追加せずに終了
             Exit Sub
         End If
     Next
     ' 見つからなければ受信者として追加
     Set objRecip = objReFw.Recipients.Add("""" & strName & """ <" & strAddr & ">")
     objRecip.Type = iType
End Sub
'
' 受信者の表示名をアドレス帳のもので置き換えるマクロ
Private Sub ReplaceDisplayName(objReply As MailItem)
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39FE001E"
     '
     Dim objRecip As Recipient
     Dim objContact As ContactItem
     Dim objAddrList As AddressList
     Dim i As Integer
     Dim objAddrEntry As AddressEntry
     Dim bFound As Boolean
     Dim cRecips As Integer
     Dim colAddress() As String
     Dim colName() As String
     Dim colType() As Integer
     '
     cRecips = objReply.Recipients.Count
     ReDim colAddress(cRecips) As String
     ReDim colName(cRecips) As String
     ReDim colType(cRecips) As Integer
     ' 受信者の情報を取得し、いったん削除
     For i = cRecips To 1 Step -1
         Set objRecip = objReply.Recipients.Item(i)
         With objRecip.AddressEntry
             If .Type = "SMTP" Then
                 colAddress(i) = objRecip.Address
             Else
                 colAddress(i) = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
             End If
         End With
         colName(i) = objRecip.Name
         colType(i) = objRecip.Type
         objReply.Recipients.Remove i
     Next
     ' 取得した受信者情報についてアドレス帳から表示名を検索し置き換え
     For i = 1 To cRecips
         Set objRecip = Nothing
         For Each objAddrList In Session.AddressLists
             If objAddrList.AddressListType = olOutlookAddressList Then
                 For Each objAddrEntry In objAddrList.AddressEntries
                     If objAddrEntry.Address = colAddress(i) Then
                         Set objRecip = objReply.Recipients.Add(colAddress(i))
                         Set objRecip.AddressEntry = objAddrEntry
                         objRecip.Type = colType(i)
                         Exit For
                     End If
                 Next
                 If Not objRecip Is Nothing Then
                     Exit For
                 End If
             End If
         Next
         ' アドレス帳で見つからなかった受信者については元の表示名で追加
         If objRecip Is Nothing Then
             If colName(i) <> colAddress(i) Then
                 Set objRecip = objReply.Recipients.Add(colName(i) & " <" & colAddress(i) & ">")
              Else
                 Set objRecip = objReply.Recipients.Add(colAddress(i))
             End If
             objRecip.Type = colType(i)
         End If
     Next
     '
     objReply.Recipients.ResolveAll
  End Sub
 

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

コメントを残す

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

WordPress.com ロゴ

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

Google フォト

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

Twitter 画像

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

Facebook の写真

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

%s と連携中