共有メールボックスの受信トレイに追加されたメールの添付ファイルを保存するマクロ

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


いつもこちらのサイトで勉強させて頂いております。

以下のマクロ(受信したメールの添付ファイルを自動保存するマクロ)を、共有メールフォルダーに対しても受信をトリガーに実行したいのですが、どのようにスクリプトを書けば良いでしょうか。

https://outlooklab.wordpress.com/2007/03/10/%E5%8F%97%E4%BF%A1%E3%81%97%E3%81%9F%E3%83%A1%E3%83%BC%E3%83%AB%E3%81%AE%E6%B7%BB%E4%BB%98%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E8%87%AA%E5%8B%95%E4%BF%9D%E5%AD%98%E3%81%99%E3%82%8B%E3%83%9E

なお、outlook 2010を使用しています。

どうぞよろしくお願い致します。


自分自身のメールボックスの受信トレイに受信したメールについては NewMailEx イベントを使用しますが、それ以外のフォルダーに関しては、そのフォルダーの Items プロパティの ItemAdd イベントを使用します。
ただ、このイベントを使用するためには、イベントが発生するフォルダーの Items を WithEvents 句付きでグローバル変数として定義し、Application_StartUp でそのグローバル変数に該当する Items オブジェクトを格納する必要があります。

マクロは以下のようになります。

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

' 共有フォルダーのイベントを取得するためのオブジェクト
Dim WithEvents sharedInboxItems As Items
'
Private Sub Application_Startup()
     ' 共有メールボックスの SMTP アドレスを指定
     Const SHARED_USER = "shareduser@example.com"
     Dim recShared As Recipient
     Dim fldSharedInbox As Folder
     ' 共有メールボックスのユーザー情報を取得
     Set recShared = Session.CreateRecipient(SHARED_USER)
     recShared.Resolve
     ' 共有メールボックスの受信トレイを取得
     Set fldSharedInbox = Session.GetSharedDefaultFolder(recShared, olFolderInbox)
     Set sharedInboxItems = fldSharedInbox.Items
End Sub
'
' 共有フォルダーの受信トレイにアイテムが追加された際に発生するイベント
Private Sub sharedInboxItems_ItemAdd(ByVal Item As Object)
     Const SAVE_PATH = "C:\temp\"
     Dim objFSO As Object ' FileSystemObject
     Dim objAttach As Attachment
     Dim strFileName As String
     Dim c As Integer: c = 1
     '
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     '
     ' 必要に応じてここで条件指定
     '
     For Each objAttach In Item.Attachments
         With objAttach
             strFileName = SAVE_PATH & objAttach.FileName
             While objFSO.FileExists(strFileName)
                 strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _
                     & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                 c = c + 1
             Wend
             .SaveAsFile strFileName
         End With
     Next
     Set objMsg = Nothing
     Set objFSO = Nothing
End Sub

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

広告

最後に返信をした日時を CSV ファイルにエクスポートするマクロ

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


outlookの受信トレイからメール返信を行ったものに対して、受信から48時間以内に
返信ができているかを確認し、集計する方法はあるのでしょうか。
返信をするとそのメールには「○月○日○時○分に返信しました」と表示されているのですが、
それが、ただ表示なのかデータとして移動できる項目なのかもわかりません。
Excelに貼り付けたりできれば、集計できるのではないかと考えているのですが、
そもそもそのようなことができるのか、他に良い方法があるのか、outlookの機能に
方法があるのかなどご存知でしたら、お教えいただけませんでしょうか。


Outlook で返信や転送を行った場合、以下のような MAPI プロパティに操作内容と日時が記録されます。

PidTagLastVerbExecuted – 最後に行った特定の操作
PidTagLastVerbExecutionTime – 最後に特定の操作を行った日時

そして、この情報をもとに Outlook は「○月○日○時○分に返信しました」というような情報を表示しています。
したがって、これらのプロパティの内容を CSV として書き出せば、集計は可能と考えられます。

ただし、このプロパティは最後に返信や転送を行った日時を記録するという点に注意が必要です。
例えば、一度全員に返信を行った後、同じメールを転送した場合、返信を行った記録は転送の記録で上書きされ、返信した日時が不明になります。
残念ながら、返信の履歴を追うようなことは困難です。

現在表示しているフォルダーのアイテムについて、返信を行ったメールの件名、受信日時、返信日時を CSV ファイルとしてエクスポートするマクロは以下のようなものになります。

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

Public Sub ExportLastReplyDate()
     On Error Resume Next
     ' MAPI の定数定義
     Const PidTagLastVerbExecuted = "http:" & "//schemas.microsoft.com/mapi/proptag/0x10810003"
     Const PidTagLastVerbExecutionTime = "http:" & "//schemas.microsoft.com/mapi/proptag/0x10820040"
     Const NOTEIVERB_REPLYTOSENDER = 102
     Const NOTEIVERB_REPLYTOALL = 103
     ' エクスポート先の CSV ファイルのパスを指定
     Const CSV_FILE_NAME = "c:\temp\replyreport.csv"
     Dim fldCurrent As Folder
     Dim itmCurrent As Variant
     Dim iVerb As Integer
     Dim dtExec As Date
     ' CSV ファイルを開く
     Open CSV_FILE_NAME For Output As #1
     ' 1 行目を書き出し
     Print #1, "件名,受信日時,返信日時"
     ' 現在表示しているフォルダーを取得
     Set fldCurrent = ActiveExplorer.CurrentFolder
     ' フォルダーのすべてのアイテムを処理
     For Each itmCurrent In fldCurrent.Items
         With itmCurrent.PropertyAccessor
             ' 最後の実行した操作を取得
             iVerb = .GetProperty(PidTagLastVerbExecuted)
             ' 操作が返信の場合
             If iVerb = NOTEIVERB_REPLYTOSENDER _
             Or iVerb = NOTEIVERB_REPLYTOALL Then
                 ' 返信を実行した日時を取得
                 dtExec = .GetProperty(PidTagLastVerbExecutionTime)
                 ' CSV に件名と受信日時、返信を実行した日時を書き出す
                 Print #1, """" & itmCurrent.Subject & """," & _
                     itmCurrent.ReceivedTime & "," & dtExec
             End If
         End With
     Next
     ' ファイルを閉じる
     Close #1
End Sub

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

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

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

Office 2016

Outlook 2016 の修正

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

Word 2016 の修正

2016 の Office のセキュリティ更新プログラムの説明: 2019 年 1 月 8日 2 件の Outlook に関する修正が行われています。

Office 2016 共通コンポーネントの修正

2016 の Word のセキュリティ更新プログラムの説明: 2019 年 1 月 8日 1 件の Outlook に関する修正が行われています。

Office 2013

Outlook 2013 の修正

Outlook 2013 のセキュリティ更新プログラムについて2018 年 12 月 12 日 1 件のセキュリティ修正と 4 件のセキュリティ以外の修正が行われています。

Office 2010

Outlook 2010 の修正

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

12周年

2007 年にこのブログをはじめて、12 周年になりました。

昨年は残念ながら年間 100 万アクセスに到達することはできませんでしたが、今でも「Outlook マクロ」で検索するとトップで表示されており、これもひとえにコメントで様々なご要望をお寄せくださる読者の方々のおかげと感謝しております。

これからも、Outlook を活用してもらうべく、様々なマクロや Tips を紹介してまいりますので、よろしくお願いいたします。

受信したメールに添付された Excel ファイルをもとに別の Excel ファイルの内容を更新するマクロ

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


お世話になります。
いつも当該サイトのコードを参考して頂いており、大変感謝致します。
さて、最近下記の様な自動処理マクロを考えておりますが、ご協力を頂きたくお願い致します。
使用環境は Windows 7, Office Pro Plus 2010
毎日倉庫より納品された貨物の実寸報告のメールが数回に受信されます。
そのメールには、商品番号と商品梱包の三辺サイズが記載されたEXCELファイルが添付されております。
件名:サイズ報告
(EXCELファイルの例:)
A列 B列 C列 D列
品番1 幅1 横1 高1
品番2 幅2 横2 高2
そのメールが受信されましたら、自動的に商品マスターファイル(excel形式)の該当商品のサイズを
更新するよう、とのマクロを考えております。  
受信したEXCELファイルを一旦保存し、その後 EXCEL側でVBA処理するなら、
特に問題なくできましたが、OUTLOOK側で自動的処理するできるなら大変助かります。
何卒、アドバイスを頂けますようお願い致します。


メールが受信された際に何らかの自動処理を行うには Application オブジェクトの NewMailEx イベントを使用します。
そして、NewMailEx イベントの EntryIDCollection には受信したアイテムのエントリー ID が格納されていますので、これを引数として Session.GetItemFromID メソッドにより受信したメール アイテムを取得できます。
メール アイテムの添付ファイルを取得するには Attachments プロパティを使用し、Attachment オブジェクトの SaveAsFile メソッドでローカルに保存します。
保存した Excel ファイルで何か処理をする手順は Excel のマクロの記述と同じです。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objMail As Object
     ' 受信したアイテムを取得
     Set objMail = Session.GetItemFromID(EntryIDCollection)
     ' アイテムがメールであり、件名が "サイズ報告" なら処理を開始
     If TypeName(objMail) = "MailItem" And objMail.Subject = "サイズ報告" Then
         ReplaceMaster objMail
     End If
End Sub
' マスター ファイルを更新するサブ
Private Sub ReplaceMaster(ByVal objMail As MailItem)
     ' 商品マスター ファイルのフルパス
     Const MASTER_FILE = "c:\temp\master.xlsx"
     ' 添付ファイルを一時保存するフォルダー (最後に \ を付ける)
     Const TEMP_FOLDER = "c:\temp\"
     ' マスター ファイルの先頭行には列名が入っていると仮定
     Const START_ROW_MASTER = 2
     ' サイズ報告のファイルは 1 行目からデータと仮定
     Const START_ROW_REPORT = 1
     '
     Dim objAttach As Attachment
     Dim strReportXls As String
     Dim wbMaster As Object ' Excel.Workbook
     Dim wsMaster As Object ' Excel.Worksheet
     Dim wbReport As Object ' Excel.Workbook
     Dim wsReport As Object ' Excel.Worksheet
     Dim i As Integer
     Dim iRow As Integer
     ' 添付ファイルがなければ処理を中断
     If objMail.Attachments.Count = 0 Then
         Exit Sub
     End If
     ' 添付ファイルを取得
     Set objAttach = objMail.Attachments(1)
     With objAttach
         ' 添付ファイルが Excel ファイルなら一時フォルダーに保存
         If .FileName Like "*.xls" Or .FileName Like "*.xls?" Then
             strReportXls = TEMP_FOLDER & .FileName
             .SaveAsFile strReportXls
         Else
             ' 添付ファイルが Excel ファイルでなければ中断
             Exit Sub
         End If
     End With
     ' マスター ファイルを取得
     Set wbMaster = GetObject(MASTER_FILE)
     wbMaster.Windows(1).Activate
     Set wsMaster = wbMaster.Sheets(1)
     ' 一時ファイルを取得
     Set wbReport = GetObject(strReportXls)
     Set wsReport = wbReport.Sheets(1)
     '
     i = START_ROW_REPORT
     ' 一時ファイルの 1 列目 (品番) にデータがなくなるまで繰り返し
     While wsReport.Cells(i, 1) <> ""
         iRow = START_ROW_MASTER
         With wsMaster
             ' マスター ファイルの 1 列目 (品番) にデータがなくなるか、
             ' 一時ファイルの 1 列目と一致するまで繰り返し
             While .Cells(iRow, 1) <> "" And _
                   .Cells(iRow, 1) <> wsReport.Cells(i, 1)
                 ' 次の行に移動
                 iRow = iRow + 1
             Wend
             ' 品番が一致したら置き換え
             If .Cells(iRow, 1) <> "" Then
                 .Cells(iRow, 2) = wsReport.Cells(i, 2)
                 .Cells(iRow, 3) = wsReport.Cells(i, 3)
                 .Cells(iRow, 4) = wsReport.Cells(i, 4)
             End If
         End With
         ' 次の行に移動
         i = i + 1
     Wend
     ' 一時ファイルは保存せずに閉じる
     wbReport.Close False
     ' マスター ファイルは保存して閉じる
     wbMaster.Close True
     ' 一時ファイルを削除する
     Kill strReportXls
End Sub

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

2019 年以降の祝日の追加、変更を行うスクリプト

12 月 14 日に「天皇の即位の日及び即位礼正殿の儀の行われる日を休日とする法律」が公布されました。

今後、この法律に基づいて更新された Outlook の祝日ファイルも更新プログラムとして提供されることになると思いますが、すでに延長サポート フェーズに入っている Outlook 2013 や Outlook 2010 には提供されない可能性があります。
また、Outlook 2016 でも、更新プログラムを適用すれば変更されるというわけではなく、いったん祝日を削除して改めて追加するという作業が必要になります。
さらに、2020 年にはオリンピックに伴う祝日の移動や、「体育の日」から「スポーツの日」への変更、天皇誕生日の変更などもあるので、2019 年から 2016  年までの祝日を追加するスクリプトを作ってみました。
なお、法律の条文などを見ても、新しい祝日の正式な呼称がわからなかったため、5/1 を「即位の日」、10/22 を「即位礼正殿の儀の日」としています。

' ここをトリプル クリックするとすべてのコードが選択できます。
'
Option Explicit
Const olFolderCalendars = 9
Const olAppointmentItem = 1
Const olFree = 0
Dim objOutlook
Dim objSession
Dim objCalendar
Dim colEvents
Dim objHoliday
Dim iYear
' Outlook アプリケーション オブジェクトの取得
Set objOutlook = CreateObject("Outlook.Application")
' Namespace オブジェクトの取得
Set objSession = objOutlook.GetNamespace("MAPI")
' 予定表フォルダの取得
Set objCalendar = objSession.GetDefaultFolder(olFolderCalendars)
Set colEvents = objCalendar.Items
' 予定表から 2019 年以降の祝日のみを取得
Set objHoliday = colEvents.Find("[分類項目] = '祝日' AND [開始日] >= '2018/12/31' AND [場所] = '日本'")
' 2019 年以降の祝日を削除
While Not objHoliday Is Nothing
     objHoliday.Delete
     Set objHoliday = colEvents.FindNext
Wend
'
' 2019 年から 2026 年までの祝日を追加
For iYear = 2019 to 2026
     AddNormalHoliday "勤労感謝の日", iYear, 11, 23
     AddNormalHoliday "文化の日", iYear, 11, 3
     AddHappyMonday "敬老の日", iYear, 9, 3
     AddNormalHoliday "こどもの日", iYear, 5, 5
     AddNormalHoliday "みどりの日", iYear, 5, 4
     AddNormalHoliday "憲法記念日", iYear, 5, 3
     AddNormalHoliday "昭和の日", iYear, 4, 29
     AddNormalHoliday "建国記念の日", iYear, 2, 11
     AddHappyMonday "成人の日", iYear, 1, 2
     AddNormalHoliday "元日", iYear, 1, 1
     ' 2019 年の新天皇即位に伴う祝日
     If iYear = 2019 Then
         AddNormalHoliday "国民の休日", iYear, 4, 30
         AddNormalHoliday "即位の日", iYear, 5, 1
         AddNormalHoliday "国民の休日", iYear, 5, 2
         AddNormalHoliday "即位礼正殿の儀の日", iYear, 10, 22
     End If
     ' 2020 以降は天皇誕生日が 2/23 に
     If iYear >= 2020 Then
         AddNormalHoliday "天皇誕生日", iYear, 2, 23
     End If
     ' 2021 以降は正常
     If iYear >= 2021 Then
         ' 体育の日はスポーツの日に
         AddHappyMonday "スポーツの日", iYear, 10, 2
         AddNormalHoliday "山の日", iYear, 8, 11
         AddHappyMonday "海の日", iYear, 7, 3
     End If
Next
' 日付が一定でない祝日の追加
AddNormalHoliday "春分の日", 2019, 3, 21
AddNormalHoliday "春分の日", 2020, 3, 20
AddNormalHoliday "春分の日", 2021, 3, 20
AddNormalHoliday "春分の日", 2022, 3, 21
AddNormalHoliday "春分の日", 2023, 3, 21
AddNormalHoliday "春分の日", 2024, 3, 20
AddNormalHoliday "春分の日", 2025, 3, 20
AddNormalHoliday "春分の日", 2026, 3, 20
AddNormalHoliday "秋分の日", 2019, 9, 23
AddNormalHoliday "秋分の日", 2020, 9, 22
AddNormalHoliday "秋分の日", 2021, 9, 23
AddNormalHoliday "秋分の日", 2022, 9, 23
AddNormalHoliday "秋分の日", 2023, 9, 23
AddNormalHoliday "秋分の日", 2024, 9, 22
AddNormalHoliday "秋分の日", 2025, 9, 23
AddNormalHoliday "秋分の日", 2026, 9, 23
' 敬老の日と秋分の日に挟まれるため
AddNormalHoliday "国民の休日", 2026, 9, 22
' 2020 年の祝日移動のための特別処理
AddNormalHoliday "海の日", 2019, 7, 15
AddNormalHoliday "山の日", 2019, 8, 11
AddNormalHoliday "体育の日", 2019, 10, 14
AddNormalHoliday "海の日", 2020, 7, 23
AddNormalHoliday "山の日", 2020, 8, 10
AddNormalHoliday "スポーツの日", 2020, 7, 24
'
' 振り替え休日を考慮しない祝日の追加
Sub AddHoliday( sName, dtDay )
     Set objHoliday = objOutlook.CreateItem(olAppointmentItem)
     objHoliday.Subject = sName
     objHoliday.Start = dtDay
     objHoliday.AllDayEvent = True
     objHoliday.Categories = "祝日"
     objHoliday.ReminderSet = False
     objHoliday.BusyStatus = olFree
     objHoliday.Location = "日本"
     objHoliday.Save
     Set objHoliday = Nothing
End Sub
'
' ハッピーマンデーの祝日の追加
Sub AddHappyMonday( sName, iYear, iMonth, iMonday )
     Dim iWk
     Dim iDay
     Dim dtDay
     iWk = Weekday(iYear & "/" & iMonth & "/1" )
     If iWk <= 2 Then
         iWk = iWk + 4
     Else
         iWk = iWk - 3
     End If
     iDay = 7 * iMonday - iWk
     AddHoliday sName, iYear & "/" & iMonth & "/" & iDay & " 00:00 AM"
End Sub
'
' 通常 (振り替え休日あり) の祝日の追加
Sub AddNormalHoliday( sName, iYear, iMonth, iDay )
     Dim iWk
     Dim dtSub
     Dim objHoliday
     AddHoliday sName, iYear & "/" & iMonth & "/" & iDay & " 00:00 AM"
     iWk = Weekday( iYear & "/" & iMonth & "/" & iDay )
     If iWk = 1 Then
         dtSub = CDate(iYear & "/" & iMonth & "/" & iDay)
         Do    ' 振替休日が国民の祝日だったら、翌日に繰り越し
             dtSub = DateAdd("d", 1, dtSub)
             Set objHoliday = colEvents.Find("[分類項目] = '祝日' AND [開始日] >= '" & _
                 dtSub & " 00:00 AM' AND [終了日] <= '" & DateAdd("d", dtSub, 1) & _
                 "' AND [場所] = '日本'")
         Loop While Not objHoliday Is Nothing
         AddHoliday "振替休日 (" & sName & ")", dtSub & " 00:00 AM"
     End If
End Sub

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

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

Office 2016

Outlook 2016 の修正

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

Office 2013

Outlook 2013 の修正

Outlook 2013 のセキュリティ更新プログラムについて2018 年 12 月 12 日
1 件のセキュリティ修正が行われています。

Office 2010

Outlook 2010 の修正

Outlook 2010 のセキュリティ更新プログラムについて2018 年 12 月 12 日
1 件のセキュリティ修正が行われています。