指定された日付範囲の送受信メール数と予定の合計時間を Excel のリポートとして作成するマクロ

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


outlook VBA初心者です。いつも参考にさせて頂いております。

Outlookで日ごと、月ごとのメール受信・送信数の分析をしたいと考えております。

具体的には以下のように、任意の期間にて何件メールを送受信したかをカウントしたいです。例えば9月1日~9月30日を選択した場合、

9月1日(水):メール受信数:100件、メール送信数:50件
9月2日(木):メール受信数:150件、メール送信数:40件
9月3日(金):メール受信数:80件、メール送信数:40件



9月30日(金):メール受信数:90件、メール送信数:40件

のような形でエクセル又はメモ帳に表示されることは可能でしょうか。

また、同様に任意の期間にて、Outlookのスケジューラに何分間の予定が入っているかをカウントしたいです。例えば9月1日~9月30日を選択した場合、

9月1日(水):90分
9月2日(木):120分
9月3日(金):150分



9月30日(金):80分

Outlook2016、Excel2016を使用しております。
お忙しい中恐れ入りますが、ご教示頂ければと思います。


日ごとの受信数や送信数については、受信トレイ フォルダーや送信済みアイテム フォルダーの Items を Restrict メソッドにより日付で絞り込み、Count プロパティで件数を取得することで算出できます。
また、予定の合計時間についても同様に日付で絞り込みを行いますが、繰り返しの予定を展開するために Sort メソッドで開始日により並べ替えを行い、IncludeRecurrences プロパティを True に設定する必要があります。
マクロは以下のようになります。

'
Public Sub MakeReport()
     Dim dtStart As Date
     Dim dtEnd As Date
     Dim dtCurrent As Date
     Dim iDays As Integer
     Dim arrCount() As String
     Dim i As Integer
     ' 開始日と終了日を入力し、範囲の日数を計算
     dtStart = InputBox("開始日")
     dtEnd = InputBox("終了日")
     iDays = DateDiff("d", dtStart, dtEnd)
     ' 日数分配列を確保
     ReDim arrCount(3, iDays)
     ' 日数の分だけ繰り返す
     For i = 0 To iDays
         ' 検索日を算出
         dtCurrent = DateAdd("d", i, dtStart)
         ' 日付に曜日を追加
         arrCount(0, i) = FormatDateTime(dtCurrent, vbShortDate) & _
                         "(" & WeekdayName(Weekday(dtCurrent), True) & ")"
         ' 受信メール数を取得
         arrCount(1, i) = GetItems(olFolderInbox, dtCurrent, "受信日時")
         ' 送信メール数を取得
         arrCount(2, i) = GetItems(olFolderSentMail, dtCurrent, "送信日時")
         ' 予定の合計時間を取得
         arrCount(3, i) = GetApptMin(dtCurrent)
     Next
     '
     Dim appExcel As Excel.Application
     Dim xlsBook As Excel.Workbook
     Dim strDate As String
     Set appExcel = CreateObject("Excel.Application")
     Set xlsBook = appExcel.Workbooks.Add()
     With xlsBook
         .Worksheets.Add
         .Worksheets(1).Name = "メール送受信数"
         .Worksheets(1).Cells(1, 1) = "日付"
         .Worksheets(1).Cells(1, 2) = "メール受信数"
         .Worksheets(1).Cells(1, 3) = "メール送信数"
         .Worksheets(2).Name = "予定の合計時間"
         .Worksheets(2).Cells(1, 1) = "日付"
         .Worksheets(2).Cells(1, 2) = "予定合計時間"
         For i = 0 To iDays
             .Worksheets(1).Cells(i + 2, 1) = arrCount(0, i)
             .Worksheets(1).Cells(i + 2, 2) = arrCount(1, i)
             .Worksheets(1).Cells(i + 2, 3) = arrCount(2, i)
             .Worksheets(2).Cells(i + 2, 1) = arrCount(0, i)
             .Worksheets(2).Cells(i + 2, 2) = arrCount(3, i)
         Next
     End With
     appExcel.Visible = True
End Sub
'
' 指定フォルダーの指定日に送受信したアイテムの数を取得する関数
'
Private Function GetItems(fldIndex As OlDefaultFolders, dtCurrent As Date, strField As String)
     Dim fldReport As Folder
     Dim dtNext As Date
     Dim strFilter As String
     Dim colItems As Items
     ' 指定日の一日後を検索範囲終了とする
     dtNext = DateAdd("d", 1, dtCurrent)
     ' フォルダーを取得
     Set fldReport = Session.GetDefaultFolder(fldIndex)
     ' 検索範囲のフィルター作成
     strFilter = "[" & strField & "] >= '" & FormatDateTime(dtCurrent, vbShortDate) & _
         "' And [" & strField & "] < '" & FormatDateTime(dtNext, vbShortDate) & "'"
     ' アイテムを検索
     Set colItems = fldReport.Items.Restrict(strFilter)
     ' 見つかったアイテム数を返す
     GetItems = colItems.Count
End Function
'
' 指定日の予定の合計時間を取得する関数
'
Private Function GetApptMin(dtStart As Date)
     Dim fldCalendar As Folder
     Dim dtNext As Date
     Dim strFilter As String
     Dim colItems As Items
     Dim apptItem As AppointmentItem
     Dim iMins As Integer
     ' 指定日の一日後を検索範囲終了とする
     dtEnd = DateAdd("d", 1, dtStart)
     ’予定表フォルダーを取得
     Set fldReport = Session.GetDefaultFolder(olFolderCalendar)
     ' 検索範囲のフィルター作成
     strFilter = "[開始日] >= '" & FormatDateTime(dtStart, vbShortDate) & _
         " 0:00' And [開始日] < '" & FormatDateTime(dtEnd, vbShortDate) & " 0:00'"
     Set colItems = fldReport.Items
     ' 予定アイテムを開始日でソート
     colItems.Sort "開始日"
     ' 繰り返しの予定を展開
     colItems.IncludeRecurrences = True
     ' アイテムを検索
     Set apptItem = colItems.Find(strFilter)
     iMins = 0
     ' アイテムが見つかっている間は繰り返す
     While Not apptItem Is Nothing
         ' 予定の時間を加算
         iMins = iMins + apptItem.Duration
         ' 次の予定を検索
         Set apptItem = colItems.FindNext
     Wend
     ' 合計の時間を返す
     GetApptMin = iMins
End Function

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

表示または選択したメールのすべての添付 Excel および PDF ファイルを印刷するマクロ

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


お世話になります。
outlook VBAの具体的で詳しい情報
ありがとうございます。

今回は、以下のようなことがやりたく質問させていただきした。

 メールに添付されているpdf,Excelファイルをマクロで
 一括印刷することは可能でしょうか。 

お忙しいところ申し訳ありませんが、よろしくお願い致します。


このブログでは受信したタイミングで添付されているファイルを印刷するというマクロについてはいくつか紹介しています。
それらのマクロの印刷部分を流用し、現在表示しているメール、またはメッセージ一覧で複数選択しているメールに添付されているファイルを印刷するマクロは以下のようになります。

' 以下はソースの先頭に記載する必要があります。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                 (ByVal hwnd As Long, ByVal lpszOp As String, _
                  ByVal lpszFile As String, ByVal lpszParams As String, _
                  ByVal LpszDir As String, ByVal FsShowCmd As Long) _
                  As Long
'
' 表示または選択したメールのすべての添付 Excel、PDF ファイルを印刷するマクロ
Public Sub PrintAllAtachments()
     Dim objItem As Variant
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objItem = ActiveInspector.CurrentItem
         PrintAllAttachCore objItem
     Else
         For Each objItem In ActiveExplorer.Selection
             PrintAllAttachCore objItem
         Next
     End If
End Sub
' メールごとに印刷を行うサブプロシージャ
Private Sub PrintAllAttachCore(ByVal objItem As MailItem)
     Const ATTACH_PATH = "c:\attachments\" ' 添付ファイルを保存するフォルダー
     Dim objAttach As Attachment
     Dim strFileName As String
     Dim c As Integer
     Dim objFSO 'As FileSystemObject
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     For Each objAttach In objItem.Attachments
         If objAttach.FileName Like "*.xl*" Or objAttach.FileName Like "*.pdf" Then
             ' ファイルが Excel または PDF の場合のみ印刷と保存
             c = 1
             With objAttach
                 strFileName = .FileName
                 While objFSO.FileExists(ATTACH_PATH & strFileName)
                     strFileName = Left(.FileName, InStrRev(.FileName, ".") - 1) _
                         & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                     c = c + 1
                 Wend
                 .SaveAsFile ATTACH_PATH & strFileName
             End With
             '    保存したファイルを印刷する
             ShellExecute 0, "print", ATTACH_PATH & strFileName, 0, ATTACH_PATH, 0
         End If
     Next
End Sub

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

サブフォルダーにメールが配信された際に処理を実行するマクロ

受信したメールに添付された Excel ファイルの 6 行目から 14 行目をローカルの Excel の最後尾に追記するマクロのコメントにて以下のご要望をいただきました。


いつも参考にさせていただき業務の効率化にはげんでおります。
こちらのマクロを受信トレイではなく、以下のフォルダに当該メールが移ってきた時に起動するようにしたいのですが、ご教授ねがえますでしょうか?

outlookでGmailのアカウントメールを受信している関係で受信トレイではなく「Gmail」トレイ?下にある「0_添付ファイル予約票印刷」でこのマクロを活用したいのですが、どのように書き換えるとよろしかったでしょうか?


特定のフォルダーにメールが移動された際に何らかの処理を実行するには、そのフォルダーの Items オブジェクトの ItemAdd イベントで処理を実装します。
ただ、Application オブジェクトとは異なり、イベントを実装するための変数を WithEvents 句付きで定義し、Outlook 起動時にその変数にオブジェクトを設定しておく必要があります。

元のマクロの CopyAttachedExcelData を NewMailEx イベントではなく IMAP のフォルダーに追加されたときの ItemAdd イベントから呼び出す場合は以下のように記述します。

'
Private WithEvents ItemsInImapFolder As Items
'
Private Sub Application_Startup()
     ' 受信トレイのサブフォルダー名を指定
     Const IMAP_FOLDER = "0_添付ファイル予約票印刷"
     Set ItemsInImapFolder = Session.GetDefaultFolder(olFolderInbox).Folders(IMAP_FOLDER).Items
End Sub
'
Private Sub ItemsInImapFolder_ItemAdd(ByVal Item As Object)
     On Error Resume Next
     CopyAttachedExcelData Item
End Sub

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

Autodiscover でパスワードが漏洩する?

セキュリティ企業の Guardicore 社が 9/23 に Autodiscover のプロトコルによりパスワードが漏洩するという情報を公開しました。

それによると、Autodiscover のフォールバック機能により autodiscover.com というサーバーに対して Autodiscover が実行されてしまい、そのサーバーを所有している組織にパスワードが漏洩するということです。

ただ、この記事には明確な誤りがあります。
以下は記事からの抜粋です。

However, in order to truly understand how Autodiscover works,
we need to know what happens “behind the scenes”:

  1. The
    client parses the email address supplied by the user –
    amit@example.com.
  2. The
    client then tries to build an Autodiscover URL based on the email address
    with the following format:
    • https://Autodiscover.example.com/Autodiscover/Autodiscover.xml
    • http://Autodiscover.example.com/Autodiscover/Autodiscover.xml
    • https://example.com/Autodiscover/Autodiscover.xml
    • http://example.com/Autodiscover/Autodiscover.xml

In the case that none of these URLs are
responding, Autodiscover will start its “back-off” procedure.
This “back-off” mechanism is the culprit of this leak because it is always
trying to resolve the
Autodiscover portion of the domain and it will always try to “fail up,” so
to speak. Meaning, the result of the next attempt to build an Autodiscover URL
would be: http://
Autodiscover.com/Autodiscover/Autodiscover.xml. This means that whoever owns Autodiscover.com will
receive all of the requests that cannot reach the original domain. For
more information about how Autodiscover works, please check out
Microsoft’s
documentation
.

誤りの一つは、http://example.com/Autodiscover/Autodiscover.xml という URL にアクセスするというものです。
Outlook の実装ではこのような URL にアクセスすることはなく、SMTP ドメイン (example.com) へのアクセスは常に https となります。

もう一つの誤りは SMTP ドメインを使用した Autodiscover がすべて失敗した場合に https://Autodiscover.com/Autodiscover/Autodiscover.xml にアクセスするというものです。
Outlook 2016検出の実装 で記載されている、SMTP ドメインに関する様々な Autodiscover の処理がすべて失敗した場合、SMTP ドメインの一部を削除して実行するというような仕様はありません。

Autodiscover の詳細についての参照先となっている Microsoft のドキュメントに関しては、単にそれぞれのサーバーにリクエストする際のプロトコルの説明しかなく、Autodiscover のフォールバック処理についての記載はありません。
本来フォールバック処理についての詳細を説明するのであれば、私が引用したほうのページを指し示すべきであり、あえてその説明がないページに誘導しているのには疑問があります。

とはいえ、実際に autodiscover.com というサーバーに Autodiscover のリクエストが届いているようですので、おそらく以下のような設定・実装の不備により認証情報が漏洩している可能性が考えられます。

  • SCP に autodiscover.com が設定されている
  • SMTPドメインや autodiscover.SMTP ドメイン の CNAME で autodiscover.com が設定されている
  • サードパーティ製のアプリケーションで誤った Autodiscover の実装がされている

設定が適切に行われている組織であれば、Autodiscover によるパスワードの漏洩は発生しないと考えられますが、どうしても不安があるということであればファイアウォールで autodiscover.com (autodiscover.co.jp だったり、autodiscover.jp だったりするかもしれません) をブロックするということになるでしょう。

受信したメールの添付ファイル名より Excel を検索し、添付ファイルごと転送するマクロ

受信したメールから取得したキーワードにより Excel を検索し、情報を追記して転送するマクロのコメントにて以下のご要望をいただきました。


いつも大変参考にさせていただいております

こちらで質問が適当かわかりませんが、お願い致します。

下記のようなマクロ、もしくは 仕分けルール用のスクリプトが必要となっております

メール受信時に 添付ファイルのファイル名(仮に 2109-001.pdf)から デスクトップにある エクセルファイルリストより ファイル名を検索しそれに紐づいた メールアドレスへ 送信されてきた添付ファイルを自動転送させたいのですが、ご教示願えませんでしょうか?

流れとして
●outlook 仕分けルールで 特定のアドレスより来た添付ファイルを保存
●添付ファイルのファイル名(拡張子部分は排除)で デスクトップ エクセルリストより 転送先アドレスを検索
●転送先アドレスに先の添付ファイルを添付して、定型文をいれて 転送

何卒宜しくお願い致します。


いただいた流れでは添付ファイルを保存して転送メールに添付するとあるのですが、Outlook でメールを転送すると、元のメールの添付ファイルも一緒に転送される動作となるので、あえて保存したり添付し直したりする必要はありません。
A 列にファイル名、B 列に転送先のアドレスが含まれている場合には、以下のようなマクロをルールのスクリプトとして指定することで実現できます。

Public Sub ForwardByExcel(ByRef objMail As MailItem)
     ' Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\file.xlsx"
     Const FORWARD_BODY = "転送します。"
     Const COL_FILENAME = 1 ' ファイル名が指定されている列
     Const COL_ADDRESS = 2  ' 転送先アドレスが指定されている列
     Const ROW_START = 2 ' ファイル名などを格納している最初の行
     Dim objAttach As Attachment
     Dim iExt As Integer
     Dim strFileRoot As String
     Dim fwdMail As MailItem
     Dim objBook
     Dim objSheet
     Dim r As Integer
     ' 添付ファイルがなければ終了
     If objMail.Attachments.Count = 0 Then
         Exit Sub
     End If
     Set objAttach = objMail.Attachments.Item(1)
     With objAttach
         ' 拡張子の位置を検索
         iExt = InStrRev(.FileName, ".") - 1
         ' 拡張子を除いたファイル名を取得
         If iExt > 0 Then
             strFileRoot = Left(.FileName, iExt)
         Else
             strFileRoot = .FileName
         End If
     End With
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     objBook.Windows(1).Activate
     Set objSheet = objBook.sheets(1)
     ' ファイル名をシートから検索
     With objSheet
         '
         r = ROW_START
         ' ファイル名が見つかるか、データがなくなるまでループ
         While .Cells(r, COL_FILENAME) <> "" And .Cells(r, COL_FILENAME) <> strFileRoot
             r = r + 1
         Wend
         ' ファイル名が見つかったら転送
         If strFileRoot = .Cells(r, COL_FILENAME) Then
             ' 転送メールを作成
             Set fwdMail = objMail.Forward
             ' 転送先アドレスを設定
             fwdMail.To = .Cells(r, COL_ADDRESS)
             ' 転送時の本文を設定
             fwdMail.Body = FORWARD_BODY
             ' 転送
             fwdMail.Send
         End If
     End With
     ' Excel ファイルを閉じる
     objBook.Close True
End Sub

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

カーソルが先頭にある行と同じ文字数の下線文字を次の行に挿入するマクロ

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


いつも参考にさせていただていおります。
メール本文のカーソルがある行の文字数を知りたいのですが、方法がわかりません。
実施したいことは
「■タイトル」の様な文字列の下に下線( ̄)を入れて

■タイトル
 ̄ ̄ ̄ ̄
の様なことをマクロで実施したいのです。
上記の場合、カーソルは「■タイトル」の行にあることが前提です。
ご教示いただければ、幸いです。


今回のご要望のように作成中の本文の文字列にアクセスするには、ActiveInspector.WordEditor により編集に使用されている Word のコンポーネントの Document オブジェクトを取得し、Word のオブジェクト モデルを使用します。
WordEditor.Parent.Selection を使用すると、Expand メソッドで行末まで選択し、Text プロパティで取得した選択文字列の長さを Len 関数で調べることで文字数が確認できます。
さらに、文字列の下に下線を入れるというような処理も MoveStart メソッドと TypeText メソッドで実装できますので、ご要望の動作は以下のようなマクロで実現できます。

'
Public Sub AddUnderLine()
     Const wdLine = 5 ' Word VBA の定数指定
     Const LINE_CHAR = " ̄" ' 挿入する文字
     Dim strLine As String
     Dim iLen As Integer
     '
     With ActiveInspector.WordEditor.Parent.Selection
         ' 行末までを選択
         .Expand wdLine
         ' 選択した文字列を取得
         strLine = .Text
         ' 文字列の長さを取得
         iLen = Len(strLine) - 1
         ' 次の行に移動
         .MoveStart wdLine, 1
         ' 選択した文字列と同じ文字数の文字を挿入
         .TypeText String(iLen, LINE_CHAR) & vbCrLf
     End With
End Sub

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

スクリプトや RPA でメールを送信すると送信トレイにたまったり、二重に送信されたりする

スクリプトや Outlook 以外の VBA、RPA などで Outlook オブジェクト モデルを使用してメールを送信する際に、以下のような現象が発生する場合があります。

  • メールが送信トレイに残ったまま送信されない
  • 一度送信したはずのメールが再送される

このような現象は、Outlook を起動していない状態でスクリプトなどによりメールを送信し、その後すぐに Outlook オブジェクト モデルのインスタンスを開放することで発生します。

Outlook はメールの送信処理をバックグラウンド処理で実行するため、Send メソッドでメールを送信すると、そのメールが送信トレイに格納されて送信処理が開始された時点で Send メソッドが終了してスクリプトなどに制御が戻ります。
つまり、Send メソッドが終了した時点では、実はまだメールの送信が完了していないことになります。

Outlook がすでに起動している状態であれば、そのまま送信処理が継続して完了するので問題はありません。
しかし、スクリプトなどにより Outlook が起動された場合は、そのスクリプトで Outlook のオブジェクトをすべて解放すると Outlook に対する外部の参照がなくなるので、Outlook の終了処理が行われます。
その結果、メールの送信処理が中断されて送信トレイにたまったり、送信ができても送信トレイのアイテムが送信済みアイテムフォルダーに移動されないことで、次回起動時に再び送信されたりするのです。

この問題を回避するには、スクリプトが実行される環境で常に Outlook を起動しておくか、メールの送信が完了するまでスクリプトから Outlook のオブジェクトを参照し続ける必要があります。
以下は、メールの送信が完了し、送信トレイからメールがなくなるまで待機するスクリプトのサンプルです。

' olkApp に Outlook.Application オブジェクトが格納されていると想定
' 送信トレイを取得
Set fldOut = olkApp.Session.GetDefaultFolder(4)
' 送信トレイにアイテムがなくなるまでループ
While fldOut.Items.Count > 0
     ' 10 秒待つ
     WScript.Sleep 10000
Wend

このサンプルだと、何らかの理由 (例えばサーバーのダウンなど) でメールの送信ができない場合にスクリプトが終わらなくなってしまうので、タイムアウトなどを設定する必要があるかもしれません。

Outlook とファイル暗号化の証明書

Outlook を使用しているときに「ファイル暗号化の証明書とキーをバックアップしてください」というメッセージが表示されることがあります。
これは、Outlook によって生成される辞書ファイルが暗号化ファイル システム (EFS) により暗号化されるためです。

Outlook とともにインストールされるアドインとして「Microsoft IME Outlook アドイン」があり、このアドインにより IME の辞書として以下の 4 つの辞書が生成されます。

  • Outlook グローバル アドレス一覧辞書 (姓)
  • Outlook グローバル アドレス一覧辞書 (名)
  • Outlook 連絡先辞書 (姓)
  • Outlook 連絡先辞書 (名)

これらの辞書は Exchange サーバーのグローバル アドレス一覧や Outlook の連絡先から、姓名とそのフリガナの情報を取得し、フリガナの文字列で変換をすると連絡先などに登録されている漢字に変換するということを可能にするものです。
全社員のフリガナ情報をグローバル アドレス一覧に登録しているような会社であれば、この辞書を使用することで社員の名前の変換が楽になるという利点があります。

そして、この辞書ファイルには姓名という個人情報が含まれることになるので、個人情報保護の観点から作成時に Windows の暗号化ファイル システムの機能により自動的に暗号化されるようになっており、「ファイル暗号化の証明書とキーをバックアップしてください」は最初に暗号化ファイル システムが使用されるときに表示されるメッセージです。
暗号化ファイル システムで暗号化されたファイルを開くためには、復号化のためのキーが必要となります。
暗号化を行った PC 自体にはキーが保存されていますが、このファイルを別の PC で開く際にはその PC にキーをインストールする必要があるため、PC の障害に備えてキーのバックアップを勧めるメッセージが表示されます。

もし、暗号化ファイル システムをこの辞書ファイル以外で使用していないなら、バックアップは不要です。
というのも、仮に PC の障害などで辞書ファイルがなくなったとしても、元になるデータはグローバル アドレス一覧や連絡先にあり、これらの情報が残っていれば辞書ファイルの再作成が可能だからです。

なお、Active Directory ドメイン環境では暗号化ファイル システムのキーはドメインで管理されており、ユーザーがバックアップする必要がないため、冒頭のメッセージが表示されることはありません。

受信したメールの添付ファイルを件名のキーワードごとに異なるフォルダーに自動保存するマクロ

受信したメールの添付ファイルを自動保存するマクロのコメントにて以下のご要望をいただきました。


いつもお世話になっております。是非ご教示いただければ助かります。

いままで一個のメールにおいて、自動保存の処理を行っておりました。

今後の件名の異なる他のメールについても、自動保存の処理を入れようと検討しております。

受信したメールの件名の文字列により異なるフォルダーへ自動的に添付ファイルを保存するマクロを参考にしたいのですが、下記 FOLDER1にはそのまま添付ファイルの名前が保存される、FOLDER2には添付ファイル+受信日の日付といったように、異なる処理を行うにはどのような記述を追加すべきでしょうか。
宜しくお願い申し上げます。


ご要望の動作を実現するには、まず添付ファイルを保存する処理を別のプロシージャに分離します。
分離したプロシージャの引数としては添付ファイルを保存するアイテムと保存先のフォルダー名、必要に応じて受信日の日付を設定するための変数を指定します。
そして、件名に特定の文字列が含まれるかどうかを InStr 関数で確認し、含まれた場合に対応するフォルダーに保存するよう引数を指定して分離したプロシージャを呼び出します。
マクロは以下のようになります。
KEYWORD1 にはそのまま添付ファイルを保存する場合の文字列、KEYWORD2 には受信日の日付を追加して保存する場合の文字列を指定します。

'
' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     SaveAttachments EntryIDCollection
End Sub
'
' 添付ファイルの保存のメイン
Private Sub SaveAttachments(ByVal strEntryID As String)
     On Error Resume Next
     Const KEYWORD1 = "key1"
     Const SAVE_PATH1 = "C:\folder1\"
     Const KEYWORD2 = "key2"
     Const SAVE_PATH2 = "C:\folder2\"
     Dim objMsg As Object
     '
     Set objMsg = Application.Session.GetItemFromID(strEntryID)
     If InStr(objMsg.Subject, KEYWORD1) > 0 Then
         SaveAttachmentsForItem objMsg, SAVE_PATH1, ""
     ElseIf InStr(objMsg.Subject, KEYWORD2) > 0 Then
         Dim strDate As String
         strDate = "_" & Format(objMsg.ReceivedTime, "YYYYMMDD")
         SaveAttachmentsForItem objMsg, SAVE_PATH2, strDate
     End If
     Set objMsg = Nothing
End Sub
'
' 実際に添付ファイルを保存するサブプロシージャ
Public Sub SaveAttachmentsForItem(objMsg As MailItem, strSavePath As String, strPrefix As String)
     Dim objFSO As Object ' FileSystemObject
     Dim objAttach As Attachment
     Dim strFileBase As String
     Dim strExt As String
     Dim strFileName As String
     Dim c As Integer
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     '
     For Each objAttach In objMsg.Attachments
         c = 1
         With objAttach
             strExt = Mid(.FileName, InStrRev(.FileName, "."))
             strFileBase = strSavePath & Left(.FileName, Len(.FileName) - Len(strExt))
             strFileName = strFileBase & strPrefix & strExt
             '
             While objFSO.FileExists(strFileName)
                 strFileName = strFileBase & "-" & c & strPrefix & strExt
                 c = c + 1
             Wend
             '
             .SaveAsFile strFileName
         End With
     Next
     Set objFSO = Nothing
End Sub

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

添付ファイルのファイル名の最後の1文字が数字に置き換わる現象について

Outlook で本文にドラッグ アンド ドロップ、または Ctrl+C & Ctrl+V でファイルを添付すると、ファイル名の最後 (拡張子の直前) が 2 や 3 といった数字に置き換わる場合があります。
これは、Word の一時ファイル フォルダー (%localappdata%\Microsoft\Windows\INetCache\Content.Word) に同名のファイルが残っている場合に発生する現象です。

Outlook の動作に Word が関わっている理由は、Outlook の本文の表示や編集に Word のコンポーネントが使用されているからです。
そのため、Outlook のメールの本文にファイルをドラッグ アンド ドロップすると、その情報は Word のコンポーネントによって処理され、以下のような流れでメールに添付されることになります。

  1. Word の一時ファイル フォルダーにファイルをコピーする
  2.   1 のファイルをメール作成画面にオブジェクトとして埋め込む
  3. 1 のファイルを削除する

問題は、1. の時点で同名のファイルが一時ファイル フォルダーにすでに存在する場合です。
このような状況では、拡張子を除くファイル名の最後を 1 に変更したファイル名でコピーされる動作となり、既に 1 が付くファイルが存在する場合は 2、3 のように増えていきます。
そして、変更後のファイル名がそのまま添付ファイルのファイル名として使用されるので、添付ファイルのファイル名の最後の 1 文字が数字に置き換わるという現象が発生するのです。

通常であれば、ファイルの添付処理が完了すると直ちに一時ファイルは削除されるので、この問題は発生しません。
このような現象が発生するのであれば、おそらくウイルス スキャン ソフトや情報漏洩防止ソフトなどファイルを監視するようなプログラムが動作しており、Word コンポーネントによるファイルの削除が失敗することが原因と考えられます。

この現象の回避策としては以下のようなものが考えられます。

  • リボンの [ファイル添付] によりファイルを添付する
  • Word の一時ファイル フォルダーのファイルをすべて削除する
  • ウイルス スキャン ソフトなどのスキャン対象から Word の一時ファイル フォルダーを除外する