一定時間内に同じ件名のメールを複数受信したらメールを送信するマクロ

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


はじめまして。
Windows10+Outlook2013で、一定時間内に同じ件名のメールを受信したら指定のメールアドレスに定型文のメールを送信したいのですが可能でしょうか?
例えば、10分間に同じ件名のメールを10件受信したら指定アドレスにメールを送る。10分間隔でメールをチェックする仕掛けになるイメージになるのでしょうか。


例えば、10分間に10件受信したかどうかという判断は、メールを受信した際にその時間の10分前以降に受信した同じ件名のメールの数をカウントして10件以上あれば、という条件に置き換えられると思います。
Items コレクションの Restriction メソッドで件名と受信日時によりフィルタリングし、その数が一定数を超えたらメールを送信するというロジックにすればご要望は実現できるでしょう。
このロジックの場合、11件目を受信した際にどうするかという問題があるのですが、これについては通知メールを送信したタイミングをフィルタリングの開始時刻にするという方法で、新たに10件受信した場合に通知するようにしています。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Dim g_strLastSent As String
'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objItem As Object ' MailItem
     '
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     '
     If objItem.MessageClass = "IPM.Note" Then
         FindSameSubject objItem.Subject
     End If
End Sub
'
Private Sub FindSameSubject(strSubject As String)
     Const NOTIFY_TO = "test@example.com"
     ' 通知メールの件名
     Const MAIL_SUBJECT = "メール通知"
     ' 通知メールの本文
     Const MAIL_BODY = "メールを 10 分以内に 10 件受信しました。"
     ' 監視する時間 (分単位)
     Const INTERVAL_MIN = 10
     ' 通知するメール数の閾値
     Const MAX_MAILS = 10
     Dim fldInbox As Folder
     Dim colInbox As Items
     Dim dtStart As Date
     Dim strStart As String
     ' 受信トレイを取得
     Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
     Set colInbox = fldInbox.Items
     ' 監視の開始時間を算出
     dtStart = DateAdd("n", -INTERVAL_MIN, Now)
     strStart = FormatDateTime(dtStart, vbShortDate) & " " & _
         FormatDateTime(dtStart, vbShortTime)
     ' 一度通知メールを送信したら、カウンタをクリアするための記述
     If g_strLastSent = "" Then
         g_strLastSent = strStart
     ElseIf g_strLastSent > strStart Then
         strStart = g_strLastSent
     End If
     ' 開始時間以降に受信した同一件名のメールの検索
     Set colInbox = colInbox.Restrict("[件名] = '" & strSubject & "' AND " & _
         "[受信日時] > '" & strStart & "'")
     ' 監視時間中に閾値を超えるメールを受信したら通知メール送信
     If colInbox.Count >= MAX_MAILS Then
         Dim mailNotify As MailItem
         Set mailNotify = Application.CreateItem(olMailItem)
         mailNotify.Subject = MAIL_SUBJECT
         mailNotify.Body = MAIL_BODY
         mailNotify.To = NOTIFY_TO
         mailNotify.Send
         ' メール送信時間を次の監視の開始時間とするロジック
         g_strLastSent = FormatDateTime(Now, vbShortDate) & " " & _
             FormatDateTime(Now, vbShortTime)
     End If
End Sub

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

広告