Reply-to が設定されているメールに返信するとき、from アドレスを To に入れる

[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を作成しました。
仕様は以下の通りです。

１　返信メールを作成するタイミングで実行される。
２　ReplyToがある場合、Fromに設定されているアドレスをToに追加する。
３　ReplyToに設定された宛先に対して、「Fromに設定されていてもToに追加しない」という例外判定を行う。
　　なお、この際のリストは外出しのテキストファイルとして定義する。
４　動作環境：Outlook2010

参考サイト

（１）ConversationIndex プロパティ (Message オブジェクト) ConversationIndex
（２）Item.To extraction from Outlook olMail-Item on ItemLoad VBA-Event
（３）メーリングリストのメールの差出人に返信し、ほかの受信者を 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