今月から 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

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

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト /  変更 )

Google フォト

Google アカウントを使ってコメントしています。 ログアウト /  変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト /  変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト /  変更 )

%s と連携中