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

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


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

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

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

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

受信したメールに添付された 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 の予定表に登録するマクロ

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


管理人様

マクロ素人にも関わらずマクロを組むことを会社に強制され困っておりこのサイトに辿り着きました。

何卒、ご助力頂きたく思います。

マクロで行いたい作業はメールで配信された複数のイベントの予定をoutlook のスケジュールに一括して登録するというものです。
例えば
2018年7月7日 イベント開始
2018年7月9日 イベントB開始
2018年7月20日 イベント開始

といった様な形で複数のイベントがメールに記載されているスケジュールの一括登録です。

イベントは毎月数多くあります。

お力添え頂ければ幸いです


ご要望の動作を実現するには、以下のような処理が必要となります。

  1. 本文を取得
  2. 1 行ずつ文字列を取得
  3. スペースの前の文字列を日付として取得
  4. スペースの後の文字列を予定の件名として取得
  5. 取得した日付と件名で予定アイテムを作成

本文は MailItem オブジェクトの Body プロパティにより取得します。
本文を 1 行ずつ処理するには改行コードまでの文字列を取り出すという処理を行いますが、改行位置を検索するには Instr 関数を使用し、文字列の分割は Left 関数と Mid 関数を使用します。
スペースの前後の文字列をそれぞれ取り出す場合も、Instr、Left、Mid 関数を使います。
文字列を日付に変換するには CDate 関数を使用します。
予定アイテムの作成は Application オブジェクトの CreateItem メソッドを使用し、取得した AppointmentItem の Subject、Start、End などを設定します。

まとめると以下のようなマクロになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub AddEventsFromSelectedItem()
     Dim objItem As MailItem
     ' 表示中のウィンドウからアイテムを取得
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objItem = ActiveInspector.CurrentItem
     Else
         Set objItem = ActiveExplorer.Selection(1)
     End If
     ' イベント登録のサブを呼び出し
     AddEventsFromItem objItem
End Sub
' イベント登録のサブルーチン
Private Sub AddEventsFromItem(ByRef objItem As MailItem)
     On Error Resume Next
     Dim strBody As String
     Dim strLine As String
     Dim iLf As Integer
     Dim iSpc As Integer
     ' アイテムから本文を取得
     strBody = objItem.Body & vbLf
     strBody = Replace(strBody, vbCrLf, vbLf)
     ' 改行位置を検索
     iLf = InStr(strBody, vbLf)
     ' 改行がなくなるまで繰り返し
     While iLf > 0
         ' 改行位置までを行として取得
         strLine = Trim(Left(strBody, iLf - 1))
         ' 取得した行を本文から削除
         strBody = Mid(strBody, iLf + 1)
         ' スペース位置を検索
         iSpc = InStr(strLine, " ")
         ' スペースがあったら登録処理
         If iSpc > 0 Then
             Dim dtEvent As Date
             Err.Clear
             ' 最初のスペースまでを日付として取得
             dtEvent = CDate(Left(strLine, iSpc - 1))
             If Err.Number = 0 Then
                 ' 日付として正しければ登録
                 Dim apptItem As AppointmentItem
                 ' 予定アイテムを作成
                 Set apptItem = CreateItem(olAppointmentItem)
                 ' スペース以降を予定の件名に設定
                 apptItem.Subject = Mid(strLine, iSpc + 1)
                 ' 開始時刻はイベントの日付
                 apptItem.Start = dtEvent
                 ' 終了時刻は翌日の 0:00
                 apptItem.End = DateAdd("d", 1, dtEvent)
                 ' イベントは終日の予定
                 apptItem.AllDayEvent = True
                 ' 予定アイテムを保存
                 apptItem.Save
             End If
         End If
         ' 次の改行位置を検索
         iLf = InStr(strBody, vbLf)
     Wend
End Sub

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

本文中に含まれる UNC のフォルダー内のファイルをすべて添付するマクロ

添付ファイルをディスクに保存し、そのファイルへのリンクをメッセージ本文に書き込むマクロのコメントにて以下のご要望をいただきました。


逆のことはできますか?
社内ネットワーク環境下で、メールに共有フォルダのリンクがはられたものが届きます、共有フォルダ内には複数のファイルがあるのですが、フォルダ共有されていない人にメール転送するのに、わずかながら手間がかかります。


メールの本文の共有フォルダーのリンク (UNC) に含まれるファイルをすべて添付する場合、以下の 2 つの作業が必要になります。

  • 本文中の UNC を取得する
  • UNC のフォルダーのファイルを添付する

本文からの UNC の取得には WordEditor プロパティとして取得できる Word の Document オブジェクトが使えるのですが、元のメールが HTML 形式の場合とテキスト形式の場合で取得方法が異なります。

まず、HTML 形式の場合、UNC がハイパーリンクになっているため、Document オブジェクトの Hyperlinks コレクションから Hyperlink オブジェクトとして取り出し、その Address プロパティにより UNC の文字列が取得可能です。

一方、テキスト形式の場合は、本文中の UNC がハイパーリンクになっていない場合があり、UNC の識別がマクロでは困難となるので、手作業で選択された文字列を取得するような処理が必要となります。
選択された文字列は WordEditor の Parent プロパティで取得できる Word の Application オブジェクトの Selection.Text で取得可能です。

UNC の文字列を取得した後は、VBA の Dir 関数でフォルダーに含まれるファイルの名前を取得し、MailItemAttachments コレクションの Add メソッドでそのファイルを添付します。

マクロは以下のようになります。
HTML 形式のように UNC がハイパーリンクになっているなら AddFilesFromLink を実行し、リンクになっていなければ UNC の文字列を選択した後で AddFilesFromSelected を実行します。

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

' 本文中でハイパーリンクになっている UNC のファイルを添付するマクロ
Public Sub AddFilesFromLink()
     On Error Resume Next
     AddFilesInAFolder ActiveInspector.WordEditor.Hyperlinks(1).Address
End Sub
' 本文中で選択した UNC のファイルを添付するマクロ
Public Sub AddFilesFromSelected()
     On Error Resume Next
     AddFilesInAFolder ActiveInspector.WordEditor.Parent.Selection.Text
End Sub
' UNC のファイルを添付するサブプロシージャ
Private Sub AddFilesInAFolder(strFolder As String)
     Dim i As Integer
     Dim objItem As MailItem
     Dim strFileName As String
    ' 渡されたフォルダーが空文字列なら何もせず終了
     If strFolder = "" Then
         Exit Sub
     End If
     ' フォルダー名の最後に余分なスペースや改行があったら削除
     For i = Len(strFolder) To 1 Step -1
         Select Case Mid(strFolder, i, 1)
             Case vbCr, vbLf, vbTab, " "
                 strFolder = Left(strFolder, i - 1)
             Case Else
                 Exit For
         End Select
     Next
    ' 表示中のアイテムを取得
     Set objItem = ActiveInspector.CurrentItem
    ' Dir 関数によりフォルダー中のファイルを取得
     strFileName = Dir(strFolder & "\*.*")
    ' フォルダーのファイルをすべて添付するまで繰り返し
     While strFileName <> ""
        ' ファイルを添付
         objItem.Attachments.Add strFolder & "\" & strFileName
        ' 次のファイルを取得
         strFileName = Dir()
     Wend
End Sub

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

今月から 3 か月分の予定表を定期的に ics ファイルに保存し、自動で特定のアドレスに送信するマクロ

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


管理人様

2016年1月30日の「予定表を定期的に ics ファイルに保存し、自動で特定のアドレスに送信するマクロ」の記事についてのお願いです。

マクロは動作しましたが、過去数年間の予定表データが膨大で管理人様がおっしゃられている通りデータ抽出にとても時間がかかっています。

お願いですが、現在より1ヶ月先あるいは2ヶ月先のデータを抽出、自動メール送信するマクロを作成いただけませんでしょうか。

ご検討のほど、よろしくお願いいたします。

当方動作環境

windows7、outlook2010


予定表にあるアイテムを特定の範囲で制限したい場合、Items オブジェクトの Restrict メソッドを使用します。
日付範囲で Restrict メソッドの条件を指定する場合、以下のようなものになります。

    アイテムの開始日時 < 範囲の終了 AND アイテムの終了日時 >= 範囲の開始

ちょっとややこしいのが、開始日時と範囲の終了、終了日時と範囲の開始を比較するという点です。
これは、範囲の境をまたぐような予定も含めるためです。

また、指定された期間の予定でフィルターするとなると、[開始日] や [終了日] でのフィルターすると考えてしまいますが、これらのプロパティでは繰り返しの予定が正しく取得できません。
例えば、10/1 から 3 か月繰り返すという予定の場合、予定アイテム自体の [開始日] や [終了日] は 10/1 となるので、実際には繰り返しの予定の一部が 11/1 以降にあっても、11/1 以降に終了する予定という条件には合致しなくなってしまいます。
そこで、繰り返しの予定を考慮する場合、条件としては [繰り返し期間の開始] と [繰り返し期間の終了] を使用します。
なお、繰り返しではない予定については繰り返し期間の開始と終了にはそのアイテム自体の開始日と終了日が設定されます。

これらを考慮したマクロは以下の通りです。

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

' 定期実行のためのタスクの件名
Const CALSEND_ITEM = "予定表自動送信タスク"
' iCal を送信するメールの件名
Const MSG_SUBJECT = "予定表送信"
' iCal を送信するメールの本文
Const MSG_BODY = "予定表を送信します"
' iCal を送信するメールの宛先
Const MSG_TO = "user1@example.com"
' iCal のローカル保存用ファイル名
Const ATT_FILE = "c:\temp\予定表.ics"
' iCal 作成の作業ファイル名
Const TEMP_FILE = "c:\temp\~temp~.ics"
'
' 起動時に自動実行されるルーチン
Private Sub Application_Startup()
     Dim fldTask As Folder
     Dim objTask As TaskItem
     Set fldTask = Session.GetDefaultFolder(olFolderTasks)
     ' 自動送信タスクの検索
     Set objTask = fldTask.Items.Find("[件名]='" & CALSEND_ITEM & "'")
     If objTask Is Nothing Then
         ' 自動送信タスクが存在しなければ作成
         Set objTask = fldTask.Items.Add
         objTask.Subject = CALSEND_ITEM
     End If
     ' 自動送信タスクのアラームを 1 日後に設定
     objTask.ReminderTime = DateAdd("d", 1, Now)
     objTask.ReminderSet = True
     objTask.Save
     ' iCal 送信
     SendMyCalendar
End Sub
'
' アラーム表示で実行されるルーチン
Private Sub Application_Reminder(ByVal Item As Object)
     ' 自動送信タスクだったら
     If Item.Subject = CALSEND_ITEM Then
         ' 一時的にアラームをオフ
         Item.ReminderSet = False
         Item.Save
         ' 自動送信タスクのアラームを 1 日後に設定
         Item.ReminderTime = DateAdd("d", 1, Now)
         Item.ReminderSet = True
         Item.Save
         ' iCal 送信
         SendMyCalendar
     End If
End Sub
'
' 予定表を iCal で送信するルーチン
Public Sub SendMyCalendar()
     On Error Resume Next
     ' ADO の定数設定
     Const adTypeText = 2
     Const adTypeBinary = 1
     Const adSaveCreateOverWrite = 2
     ' 送信する月の数を設定
     Const MONTH_SPAN = 3
     '
     Dim fldCalendar As Folder
     Dim strStart As String
     Dim strEnd As String
     Dim colAppts As Items
     Dim oneAppt As AppointmentItem
     Dim stmWrite 'As ADODB.Stream
     Dim stmRead 'As ADODB.Stream
     Dim strText As String
     Dim binIcs As Variant
     Dim msgSend As MailItem
     ' UTF-8 で iCal ファイルを作成するためのストリーム作成
     Set stmWrite = CreateObject("ADODB.Stream")
     With stmWrite
         .Type = adTypeText
         .Charset = "UTF-8"
         .Open
         ' iCal のヘッダーを書き込み
         .WriteText "BEGIN:VCALENDAR" & vbCrLf
         .WriteText "PRODID:-//Microsoft Corporation//Outlook 12.0 MIMEDIR//EN" & vbCrLf
         .WriteText "VERSION:2.0" & vbCrLf
         .WriteText "METHOD:PUBLISH" & vbCrLf
         .WriteText "X-WR-CALNAME:" & Session.CurrentUser & vbCrLf
     End With
     ' 既定の予定表を取得
     Set fldCalendar = Session.GetDefaultFolder(olFolderCalendar)
     ' 今日の日付から MONTH_SPAN で設定された範囲を設定
     strStart = Format(Now, "yyyy/mm/01 0:00")
     strEnd = Format(DateAdd("m", MONTH_SPAN, strStart), "yyyy/mm/01 0:00")
     ' アイテムをフィルターする
     Set colAppts = fldCalendar.Items.Restrict("[繰り返し期間の開始] < '" & strEnd & "' AND [繰り返し期間の終了] > '" & strStart & "'")
     ' フィルターした予定アイテムを処理
     For Each oneAppt In colAppts
         Err.Clear
         ' 単一のアイテムを iCal として保存
         oneAppt.SaveAs TEMP_FILE, olICal
         If Err.Number = 0 Then
             ' iCal ファイルを UTF-8 として読み込む
             Set stmRead = CreateObject("ADODB.Stream")
             With stmRead
                 .Type = adTypeText
                 .Charset = "UTF-8"
                 .Open
                 .LoadFromFile TEMP_FILE
                 strText = .ReadText
                 .Close
             End With
             ' iCal データのうち VEVENT の部分だけ抜きとり
             strText = Mid(strText, InStr(strText, "BEGIN:VEVENT"))
             strText = Left(strText, InStr(strText, "END:VCALENDAR") - 1)
             ' 送信用 iCal ファイルへ書き込み
             stmWrite.WriteText strText ' adWriteChar
         End If
         DoEvents
     Next
     '
     With stmWrite
         ' iCal ファイルの終わりを書き込み
         .WriteText "END:VCALENDAR" & vbCrLf
         ' iCal ファイルの保存
         .SaveToFile ATT_FILE, adSaveCreateOverWrite
         .Close
     End With
     ' iCal ファイルを添付してメールを送信
     Set msgSend = CreateItem(olMailItem)
     msgSend.Subject = MSG_SUBJECT
     msgSend.Body = MSG_BODY
     msgSend.To = MSG_TO
     msgSend.Attachments.Add ATT_FILE
     msgSend.Send
End Sub

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