Exchange 環境で受信したメールの差出人を連絡先の表示名に置き換えるマクロ

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


いつも勉強させていただいてます。
ありがとうございます。
受信したメールの差出人を連絡先
から検索するを使用していますが、
outlookを起動してない時に受信した
メールはvbaが反映されません。
対応可能でしょうか?
ぜひご教示いただければ幸いです。
よろしくお願いいたします。

連続ですいません。
過去のコメント等拝見して
exchangeの場合ルールに
スクリプトを追加するれば
良いとのことを理解したのですが、
どのマクロを登録したら
良いのでしょうか??


ルールでマクロを実行する場合、Public Sub プロシージャ名(ByRef メール変数 As MailItem) として処理を行うプロシージャを定義し、ルールのスクリプトを実行するアクションとして指定します。
ただし、2017 年 5 月以降にリリースされた修正プログラムを適用すると、スクリプトのアクションが新規に作成できなくなり、既存のものもエラーとなります。
そのため、これを回避するにはこちらの記事で紹介しているレジストリ設定を行う必要があります。
レジストリ設定を行った後、「連絡先をマクロで活用する」で紹介した「受信したメールの差出人を連絡先から検索する」マクロをルールで実行できるように書き換えると以下のようになります。
なお、FindContactByAddress 関数は前述の記事で紹介したものに含まれていますので、既に登録済みであれば RewriteSenderAction のみをコピーしてください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 差出人の名前を置き換えるサブプロシージャ
Public Sub RewriteSenderAction(ByRef objMail As MailItem)
     On Error Resume Next
     Dim objContact As ContactItem
     Dim strSenderAddress As String
     '
     strSenderAddress = objMail.SenderEmailAddress
     Set objContact = FindContactByAddress(strSenderAddress)
     If Not objContact Is Nothing Then
         objMail.SentOnBehalfOfName = objContact.FileAs
         objMail.Save
     End If
End Sub
' 差出人のアドレスで連絡先を検索する関数 (既に登録済みならコピー不要)
Private Function FindContactByAddress(strAddress As String)
     Dim objContacts 'As Folder
     Dim objContact As ContactItem
     '
     Set objContacts = Application.Session.GetDefaultFolder(olFolderContacts)
     Set objContact = objContacts.Items.Find("[Email1Address] = '" & strAddress _
         & "' or [Email2Address] = '" & strAddress _
         & "' or [Email3Address] = '" & strAddress & "'")
     Set FindContactByAddress = objContact
End Function

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

Outlook 2016/2013/2010/ 2007 のセキュリティ修正プログラム 2018 年 2 月分がリリース

2/13 に Office 2016, 2013, 2010 および 2017 のセキュリティ修正プログラムがリリースされました。以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 のセキュリティ修正

2016 の Outlook のセキュリティ更新プログラムの説明: 2018 年 2 月 13日
2 件のセキュリティ修正と 5 件のセキュリティ以外の修正が行われています。

Office 2013

Outlook 2013 のセキュリティ修正

Outlook 2013 のセキュリティ更新プログラムの説明: 2018 年 2 月 13日
2 件のセキュリティ修正と 6 件のセキュリティ以外の修正が行われています。

Office 2010

Outlook 2010 のセキュリティ修正

Outlook 2010 用のセキュリティ更新プログラムの説明: 2018 年 2 月 13日
2 件のセキュリティ修正が行われています。

Office 2007

Outlook 2007 のセキュリティ修正

Outlook 2007 用のセキュリティ更新プログラムの説明: 2018 年 2 月 13日
2 件のセキュリティ修正が行われています。

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

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


はじめまして。
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

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

送信済みアイテムのメールについて期間を指定して特定の文字列を件名に含むメールにテンプレートで返信するマクロ

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


はじめまして、はせがわと申します。
Outlookのマクロを作りたいとネットを検索していて貴サイトを拝見し、ご質問させていただきたく思いました。

やりたいこと
社員向けに500件くらいのメールをAccessから自動送信しています。
  本メールには社内試験の結果等をパスワードを付したファイルをメールに添付して受験者に送信しました。
パスワードを知らせるメールを受験生全員に上記メールに返信する形です送付したいと考えています。

具体的には、特定のメール(タイトルと日付)を探し出し、本メールへの返信メールを作成し、パスワードを連絡するメールを送信したい。
  1.送信トレイの中から、期間指定(YYYYMMD-YYYYMMDD)およびメールタイトル(キーワード部分一致:”結果送付のお知らせ”)で対象メールを特定する。
  2.対象メールにReplyAllで返信する形でメールを作成する。
  3.本文にパスワードを伝えるテンプレートを加える
4.送信

※知りたいところ、
  1.特定のフォルダからのメールの検索方法
  2.ReplyAllの返信メールを作成する方法

以上、よろしくお願いたします。


送信トレイの中から、とありますが、これは送信済みアイテムと考えてよいでしょうか?
アイテムを送信日時でフィルターするには Items オブジェクトの Find メソッドが使用できます。
また、メールの件名のキーワードの部分一致は Instr 関数を使用します。
下記のマクロでは C:\temp\password.oft として保存したテンプレート メールの本文で返信メールの本文を置き換え、送信しています。

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

Public Sub SendPasswordByReply()
     Const KEY_WORD = "結果送付のお知らせ"
     Const TEMPLATE_FILE = "c:\temp\password.oft"
     Dim strStart As String
     Dim strEnd As String
     Dim fldSent As Folder
     Dim colSent As Items
     Dim tmpMail As MailItem
     Dim orgMail As MailItem
     Dim repMail As MailItem
     ' 検索期間の開始と終了を入力
     strStart = InputBox("検索期間の開始日(YYYYMMDD)")
     strEnd = InputBox("検索期間の終了日(YYYYMMDD)")
     strStart = Left(strStart, 4) & "/" & Mid(strStart, 5, 2) & "/" & Right(strStart, 2)
     strEnd = Left(strEnd, 4) & "/" & Mid(strEnd, 5, 2) & "/" & Right(strEnd, 2)
     strEnd = DateAdd("d", 1, CDate(strEnd))
     ' テンプレートを取得
     Set tmpMail = Application.CreateItemFromTemplate(TEMPLATE_FILE)
     ' 送信済みアイテムフォルダーを取得
     Set fldSent = Session.GetDefaultFolder(olFolderSentMail)
     Set colSent = fldSent.Items
     ' 指定された期間に送信されたアイテムを検索
     Set orgMail = colSent.Find("[送信日時]>='" & strStart & "' And [送信日時]<'" & strEnd & "'")
     While Not orgMail Is Nothing
         ' 件名にキーワードを含むメールについて処理
         If InStr(orgMail.Subject, KEY_WORD) > 0 Then
             ' 全員に返信
             Set repMail = orgMail.ReplyAll
             ' テンプレートの本文を返信メールの本文と置き換え
             repMail.Body = tmpMail.Body
             ' テンプレートの本文を返信メールの先頭に入れる場合は以下のようにする
             ' repMail.Body = tmpMail.Body & repMail.Body
             ' メールを送信
             repMail.Send
         End If
         Set orgMail = colSent.FindNext
     Wend
End Sub

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