[Outlook VBA]Reply-to が設定されているメールに返信するとき、from アドレスを To に入れる
本記事の解説
まず、本コードは、2015/11~2018/1の間勤務していた職場で使うために作ったコードです。
社外から社内へコードを持ち込む際に、メールや外部記憶媒体を使わない手段を考えたときに選んだ手段が「サイト経由」でした。
そして本記事が書かれたのも1年以上前であり、ほぼ内容そのままの転載ですので陳腐化している可能性もあります。
ただし、当時の日本国内の記事では、with events を使ってeventを拡張する手順を記載したものはありませんでした。
検索してないですけど、今はあるのでしょうか。
ともあれ、何かの参考になれば幸いです。
概要
Reply-to に メーリングリストが設定されているメールに返信するとき、from アドレスを To に入れるVBAです。
メーリングリストを活用する際、ReplyToにメーリングリストを設定するのはよくある事ですが、
メーリングリスト外からメーリングリストにメール送信を行われた場合、その返信の時に差出人が宛先から漏れてしまいます。
そこで、Reply-toがある場合に、FromのユーザーをToに追加するVBAを作成しました。
仕様は以下の通りです。
1 返信メールを作成するタイミングで実行される。
2 ReplyToがある場合、Fromに設定されているアドレスをToに追加する。
3 ReplyToに設定された宛先に対して、「Fromに設定されていてもToに追加しない」という例外判定を行う。
なお、この際のリストは外出しのテキストファイルとして定義する。
4 動作環境:Outlook2010
参考サイト
(1)ConversationIndex プロパティ (Message オブジェクト) ConversationIndex
(2)Item.To extraction from Outlook olMail-Item on ItemLoad VBA-Event
(3)メーリングリストのメールの差出人に返信し、ほかの受信者を Cc に指定するマクロ
なお。メーリングリスト自身がfromに設定されていることもありますので、
メーリングリストのメンバーとしてメーリングリスト自身も追加しておくのがお勧めです。
コード
以下、コードと解説を記載します。
ThisOutlookSession
返信メールが作成されたタイミングで処理を行うためクラスインスタンスを作成し、
返信メールのItemLoadイベントでクラス「cc」に返信メールのオブジェクトを渡しています。
ItemLoadの時点では初期化処理が行われていないため、VBAからプロパティへの参照・書き込みができません。
そこで、クラスインスタンスの中でOpenイベントを拾う様にしています。
Option Explicit 'クラスインスタンス作成 Dim cc As New cc Private Sub Application_ItemLoad(ByVal Item As Object) If (TypeOf Item Is MailItem) Then Set cc.myItem = Item End If End Sub
cc
クラスモジュール「cc」を追加し、以下のコードを貼り付けてください。
メインの処理です。クラスモジュールで定義した、アイテムのオープンイベントで処理を行います。
まず、インスペクター全体から返信元文書を探し、見つからなかった場合は、アクティブエクスプローラーの選択行を確認し、返信元文書を見つけます。
インスペクターには、Outlookアイテムのうち、開かれているすべてのアイテムが含まれます。
アクティブエクスプローラーは、Outlookのリスト表示です。
次に、ReplyToアドレスがある場合に処理を行います。
ただし、ReplyToアドレスがメーリングリストである前提で処理を組んでいます。
Fromに指定されたアドレスがメーリングリストに含まれているかどうかの判定を、「isMember」関数で行っていますが、
今回、メーリングリスト参加者のリストはテキストファイルとして外出ししました。
なお、ファイルサーバー上に配置しても問題なく動作します。
ちなみに、メーリングリストに配布リストを使っている場合は自動でメンバー確認する処理も作成できるのですが、
ユースケースとして需要が低いと考えましたので、今回はロジックを組んでいません。
Option Explicit Public WithEvents myItem As Outlook.MailItem Private Sub myItem_Open(Cancel As Boolean) 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 objReply As MailItem '返信文書 Dim objMail As MailItem '返信元文書 Dim objRecipient As Outlook.Recipient Dim objInspector As Outlook.Inspector Dim strConversationTopic As String Dim strConversationIndex As String Dim strTemp As String Dim strSubject As String Dim strConversationIndex4Org As String '返信元文書のConversationIndex Dim strRecipient As String '送信していないアイテムのみ処理する If myItem.Sent = True Then Exit Sub End If '自分自身のConversationTopicとConversationIndexを取得 Set objReply = myItem strConversationTopic = objReply.ConversationTopic strConversationIndex = objReply.ConversationIndex '新規メールについては処理を行わない If strConversationIndex = "" Then GoTo End_Sub End If '返信元文書のConversationIndexを作成する。 '返信時、strConversationIndexは末尾に8バイトのタイムスタンプが追加されるので、これを削除する。ただし、削除するのは10バイト。理由は不明。 '【参考URL】https://msdn.microsoft.com/ja-jp/library/cc420686.aspx strConversationIndex4Org = Left(strConversationIndex, Len(strConversationIndex) - 10) 'すべてのインスペクターから、返信元文書を検索する strTemp = "" For Each objInspector In Inspectors Set objMail = objInspector.CurrentItem If objMail.ConversationIndex = strConversationIndex4Org Then strTemp = strTemp & "Inspector:" & objReply.Subject & vbCrLf Exit For End If Set objMail = Nothing Next '返信元が無い場合、ActiveExplorerの選択範囲が返信元文書かどうか確認する '複数範囲指定されている場合については考慮しない If strTemp = "" Then Set objMail = ActiveExplorer.Selection(1) If objMail.ConversationIndex = strConversationIndex4Org Then strTemp = strTemp & "ActiveExplorer:" & objMail.Subject & vbCrLf End If End If '返信元文書を取得できなかった場合、処理を終了する If strTemp = "" Then GoTo End_Sub End If '送信時、ReplyTo有無を確認する If objMail.ReplyRecipients.Count > 0 Then 'ReplyToが1以上のとき、処理を行う ' From のアドレスと表示名を取得 If objMail.SenderEmailType = "SMTP" Then 'SMTPから受信した場合 strFromAddress = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_EMAIL_ADDRESS) strFromName = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_NAME) Else 'SMTP以外から受信した場合 strFromAddress = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_SMTP_ADDRESS) strFromName = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_NAME) End If 'Fromを返信先に加えるか判定する If isMember(strFromAddress, objMail.ReplyRecipients) = False Then 'From のアドレスについて、名前がついていれば名前付きアドレスにする If strFromAddress <> strFromName Then strRecipient = """" & strFromName & """" & "<" & strFromAddress & ">" Else strRecipient = strFromAddress End If 'Fromが返信先に含まれていない場合、Toに追加する objReply.Recipients.Add strRecipient End If End If End_Sub: 'オブジェクトの解放 If IsNull(objReply) = False Then Set objReply = Nothing End If If IsNull(objMail) = False Then Set objMail = Nothing End If End Sub Private Function isMember(strFromAddress As String, objMailingLists As Outlook.Recipients) As Boolean 'メーリングリストの中にメンバーが所属しているか判定する '引数: ' strFromAddress :判定するメンバー ' objMailingLists :メーリングリスト(複数) Const MAILING_LISTS As String = "C:\temp\mailing_lists.txt" Dim intFreeFile As Integer Dim lngIdx As Long Dim strMailingList As String Dim strBuf As String '戻り値初期化 isMember = False For lngIdx = 1 To objMailingLists.Count 'メーリングリストが複数あった場合も、すべてについて確認を行う 'メーリングリスト文字列初期化 strMailingList = objMailingLists.Item(lngIdx).Address '空き番号取得 intFreeFile = FreeFile 'メーリングリストファイルを開く Open MAILING_LISTS For Input As intFreeFile 'EOFが来るか、メーリングリスト+メンバーの組が見つかるまでループ Do '1行読み込む Line Input #intFreeFile, strBuf '対象のメーリングリストが見つかった場合、リストを探索 If strBuf = strMailingList Then Do '1行読み込む Line Input #intFreeFile, strBuf 'EOF_LISTが来るまでループ If strBuf = "#EOF_LIST" Then Exit Do End If '読み込んだアドレスが引数と一致していた場合、メーリングリストに含まれるメンバーだと判定 If strBuf = strFromAddress Then 'メーリングリストとメンバーの組があった isMember = True strBuf = "#EOF" Exit Do End If Loop End If 'EOFが来るまでループ If strBuf = "#EOF" Then Exit Do End If Loop 'メーリングリストファイルを閉じる Close #intFreeFile Next End Function
mailing_lists.txt
メーリングリストを記述するファイルです。
記載例を以下に示します。
なお、ファイル終端に「#EOF」とわざわざ記載したのは、コードで楽をするためです。
普通に「eof(1)」で判定しても良いのですが、そうすると、メンバーが見つかった後の処理について、
gotoを使うか、if条件を追加する事になるので、終了条件に使いませんでした。
#reply-to にメーリングリストが入っていた場合、Fromに入っていてもToに移動しないメンバーを記載します。 #ここに記載のないメーリングリストやメンバーについては、FromからToに追加されます。 #メーリングリストを追加した場合、リストの最後に「#EOF_LIST」を追加してください。 munimuni@googlegroups.com #EOF_LIST hogehoge@googlegroups.com wasawasa@g-mail.co.jp #EOF_LIST #EOF