outlookの「定期的な予定」アイテムから実際の予定日時を取得し、Excelで一覧化するマクロ

outlookで会議開催する際、「定期的な予定」として設定すると、毎週月曜日の9時から10時まで、のような会議を1回の作業で登録できます。毎週、毎月など繰り返しのパターンや、いつまで何回など開催する期間も指定でき、重宝している方も多いのではないでしょうか。この定期的な予定から、発行されている実際のスケジュール日時をVBAで取得したい状況となり、色々と試してみたのですが、これがなかなか上手くいきません。

定期的なスケジュールの開始日、終了日、繰り返しの期間や頻度、例外日などの設定した条件はAppointmentItemオブジェクトのメソッド「GetRecurrencePattern()」で取得できるのですが、発行されているスケジュール日時そのものの情報は取得できません。まあ、取得した条件から、自力で日時を生成することもできそうですが、「毎週金曜日」ならまだしも、「毎月第１金曜日」とか「毎年4月1日」とか「すべての平日」とか、およそ考えられる条件で柔軟に定期的な予定を設定できるようになっているので、自力生成はかなり面倒なことになりそうです。折角outlookに秀逸な定期的な予定条件を指定する機能があるのですから、その結果だけをサクッと拝借したいわけです。

GetRecurrencePattern()で取得したオブジェクトのメソッドとして「GetOccurrence」があり、予定の開始日時を引数として指定すると、該当する日時に対応するインスタンスを返してくれます。ただ、指定した日時に対応するインスタンスが存在しない場合は、エラーとなるようなのですが、そのエラーメッセージがよくわからないのです。

コレクションで全ての日時一覧を返してくれるGetOccurrence「s」のようなメソッドがあれば嬉しいのですが、残念ながら、そういう便利なメソッドやプロパティはなさそうでした。

であれば力技で。幸いにして開始時間は一定なので、1年分の予定を取得したい場合は365回、GetOccurrenceでインスタンスを取得してみて、取得できた場合は、スケジュールが発行されていると判断、その日時を一覧化することにしましょう。次のコードを、スケジュール日時を取得したい予定を開いた状態で実行すると、表示されているワークシートのA列に年月日、B列に開始時間、C列に終了時間が表示されます。

'---------------------------------------------------------
'定期的な予定から発行されているスケジュール日時を取得する
'---------------------------------------------------------
Sub 予定日時取得()
    
    Dim olApp As Object, olAppt As Object, olRange As Object, olRecurrence As Object
    Dim dStartDate As Date, dEndDate As Date
    Dim i As Integer, r As Long, n As Long, MyRtn, strTitle As String
    Set olApp = CreateObject("Outlook.Application")
    
    On Error Resume Next 'アイテムが開いていない場合に備えエラー回避
     Set olAppt = olApp.Application.ActiveInspector.CurrentItem
    On Error GoTo 0
    
    If olAppt Is Nothing Then
        MsgBox "日時を取り込む予定を開いた状態で実行してください"
        Exit Sub
    ElseIf olAppt.Class <> 26 Then 'olAppointment以外
        MsgBox "予定以外のアイテムがアクティブとなっています。予定を開いて実行してください。"
        Exit Sub
    End If
    
    strTitle = olAppt.Subject
    If strTitle = "" Then strTitle = "無題"
    MyRtn = MsgBox("「件名:" & strTitle & "」から予定日時を取得します", vbOKCancel)
    If MyRtn = vbCancel Then Exit Sub
    
    Columns("A:C").ClearContents
    r = 1
    
    Set olRecurrence = olAppt.GetRecurrencePattern()
    dStartDate = olAppt.Start   '開始日時
    dEndDate = olRecurrence.PatternEndDate  '最終日時
    
    If olAppt.IsRecurring Then  '定期的な予定の場合
        For i = 0 To Application.Min(DateDiff("d", dStartDate, dEndDate), 365)  '最長1年
            Set olRange = Nothing
            On Error Resume Next  'エラー回避
               Set olRange = olRecurrence.GetOccurrence(dStartDate + i)
            On Error GoTo 0
            If Not olRange Is Nothing Then
                Cells(r, 1) = Format(olRange.Start, "yyyy/mm/dd")
                Cells(r, 2) = Format(olRange.Start, "hh:mm")
                Cells(r, 3) = Format(olRange.End, "hh:mm")
                r = r + 1
            End If
        Next i
    Else    '単体予定の場合
        Cells(r, 1) = Format(olAppt.Start, "yyyy/mm/dd")
        Cells(r, 2) = Format(olAppt.Start, "hh:mm")
        Cells(r, 3) = Format(olAppt.End, "hh:mm")
        r = r + 1
    End If
    
    Set olApp = Nothing: Set olAppt = Nothing: Set olRecurrence = Nothing: Set olRange = Nothing
    MsgBox "「件名：" & strTitle & "」から、" & r & "件の予定日時を取得しました"

End Sub

'---------------------------------------------------------

'定期的な予定から発行されているスケジュール日時を取得する

'---------------------------------------------------------

Sub 予定日時取得()

Dim olApp As Object, olAppt As Object, olRange As Object, olRecurrence As Object

Dim dStartDate As Date, dEndDate As Date

Dim i As Integer, r As Long, n As Long, MyRtn, strTitle As String

Set olApp = CreateObject("Outlook.Application")

On Error Resume Next 'アイテムが開いていない場合に備えエラー回避

Set olAppt = olApp.Application.ActiveInspector.CurrentItem

On Error GoTo 0

If olAppt Is Nothing Then

MsgBox "日時を取り込む予定を開いた状態で実行してください"

Exit Sub

ElseIf olAppt.Class <> 26 Then 'olAppointment以外

MsgBox "予定以外のアイテムがアクティブとなっています。予定を開いて実行してください。"

Exit Sub

End If

strTitle = olAppt.Subject

If strTitle = "" Then strTitle = "無題"

MyRtn = MsgBox("「件名:" & strTitle & "」から予定日時を取得します", vbOKCancel)

If MyRtn = vbCancel Then Exit Sub

Columns("A:C").ClearContents

r = 1

Set olRecurrence = olAppt.GetRecurrencePattern()

dStartDate = olAppt.Start '開始日時

dEndDate = olRecurrence.PatternEndDate '最終日時

If olAppt.IsRecurring Then '定期的な予定の場合

For i = 0 To Application.Min(DateDiff("d", dStartDate, dEndDate), 365) '最長1年

Set olRange = Nothing

On Error Resume Next 'エラー回避

Set olRange = olRecurrence.GetOccurrence(dStartDate + i)

On Error GoTo 0

If Not olRange Is Nothing Then

Cells(r, 1) = Format(olRange.Start, "yyyy/mm/dd")

Cells(r, 2) = Format(olRange.Start, "hh:mm")

Cells(r, 3) = Format(olRange.End, "hh:mm")

r = r + 1

End If

Next i

Else '単体予定の場合

Cells(r, 1) = Format(olAppt.Start, "yyyy/mm/dd")

Cells(r, 2) = Format(olAppt.Start, "hh:mm")

Cells(r, 3) = Format(olAppt.End, "hh:mm")

r = r + 1

End If

Set olApp = Nothing: Set olAppt = Nothing: Set olRecurrence = Nothing: Set olRange = Nothing

MsgBox "「件名：" & strTitle & "」から、" & r & "件の予定日時を取得しました"

End Sub

このコード実行結果がこちら。シート上、定期的な予定が一覧化されました。

ポイントはここですね。 On Error Resume Next で、上記の変なエラーを無視、事前にolRangeオブジェクトをNothingにして、インスタンスが返ってきてるかどうかを判断しています。

            Set olRange = Nothing
            On Error Resume Next  'エラー回避
               Set olRange = olRecurrence.GetOccurrence(dStartDate + i)
            On Error GoTo 0
            If Not olRange Is Nothing Then

Set olRange = Nothing

On Error Resume Next 'エラー回避

Set olRange = olRecurrence.GetOccurrence(dStartDate + i)

On Error GoTo 0

If Not olRange Is Nothing Then

どうせなら祝日の判定もしたくなります。定期的な予定で会議設定して、祝日に開催してしまうこと、よくあります。内閣府のホームページで公開されているcsvを開いて、「祝日」シートに転記するマクロです。

Sub 祝日取得()

    Const url As String = "https://www8.cao.go.jp/chosei/shukujitsu/syukujitsu.csv"
    Dim Wb As Workbook
    
    Set Wb = Workbooks.Open(Filename:=url)
    Wb.Activate
    Columns("A:B").Copy
    ThisWorkbook.Sheets("祝日").Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    Wb.Close

End Sub