以前公開した「メーリングリストのメールの差出人に返信するマクロ」について以下のようなご要望をいただきました。
もし、ご対応頂けるならば、以下のようにアドレスが入るものを作成して頂けないでしょうか。
「全員へ返信」をするメールのときに、
・宛先欄に、元メールの差出人アドレス（これ1個）
・CC欄に、その他の全てのアドレス
以前に、以下を記載しましたが、宛先に複数のアドレスが入るため、それをCC欄に移動する手間を無くしたいだけなのですが。。。
—–
（アドレス欄にアドレスがあれば、アドレスをコピペする手間が無くなるので）
—–
横着な希望ですが、相手方によっては、細かい方もいて、私のアドレスが何で”TO”なんだという方も稀にいるので。。。
メーリングリストの返信に元の差出人を加えると、その人にはメールが2通届く可能性があるのですが、それでもかまわないとのことであれば以下のようなマクロとなります。
' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ReplyAllAndOriginalSender()
Const PR_SENT_REPRESENTING_EMAIL_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x0065001e"
Const PR_SENT_REPRESENTING_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x5d02001e"
Const PR_SENT_REPRESENTING_NAME = "http://schemas.microsoft.com/mapi/proptag/0x0042001e"
Dim strFromAddress As String
Dim strFromName As String
Dim objMail As MailItem
Dim objReply As MailItem
Dim objRec As Recipient
' アクティブ ウィンドウがメッセージなら開いているメッセージに返信
If TypeName(Application.ActiveWindow) = "Inspector" Then
Set objMail = ActiveInspector.CurrentItem
Else ' アクティブ ウィンドウがメッセージ一覧なら選択しているメッセージに返信
Set objMail = ActiveExplorer.Selection(1)
End If
Set objReply = objMail.ReplyAll
' From のアドレスと表示名を取得
If objMail.SenderEmailType = "SMTP" Then
strFromAddress = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_EMAIL_ADDRESS)
strFromName = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_NAME)
Else
strFromAddress = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_SMTP_ADDRESS)
strFromName = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_NAME)
End If
For Each objRec In objReply.Recipients
objRec.Type = olCC
Next
' 宛先に From を追加
If strFromName <> strFromAddress Then
objReply.Recipients.Add strFromName & " <" & strFromAddress & ">"
Else
objReply.Recipients.Add strFromAddress
End If
' 返信メッセージを表示
objReply.Display
End Sub
Outlook 研究所 