[VBA]Outlook予定表 分類ごとに時間集計

Microsoft のWEBサイトに載っている集計サンプルは非常に複雑でしたのでソースコードをすっきりさせました

指定された分類での累積時間を計算します。Me.ComboBox1.Text には 年/月 を選択させています。

ソース

    Dim SumTime As Long '集計時間（分）

    '範囲を考える
    Dim STDATE As Date
    Dim ENDATE As Date

    STDATE = Me.ComboBox1.Text & "/01"
    ENDATE = DateAdd("m", 1, STDATE) & " 00:00"
    
    Dim colAppts As Items
    
    Set colAppts = Session.GetDefaultFolder(olFolderCalendar).Items
    colAppts.Sort "[Start]"
    colAppts.IncludeRecurrences = True  '定期的な予定があってもこの行で取得可能！
    
    
    Dim colApptsFind As AppointmentItem
    Set colApptsFind = colAppts.Find("[Start] >= '" & STDATE & "' AND [END] < '" & ENDATE & "'")
    
    While Not colApptsFind Is Nothing
    
        If InStr(1, colApptsFind.Categories, "ここに分類名を入れます") > 0 Then
             SumTime = SumTime + colApptsFind.Duration
        End If
    
        Set colApptsFind = colAppts.FindNext
    Wend
    
    MsgBox Int(SumTime / 60) & " 時間 " & SumTime Mod 60 & " 分", vbInformation