如何在Outlook VBA宏中过滤特定主题的会议？

原代码依赖Outlook的FreeBusy方法统计忙碌时长，但这个方法无法区分会议主题，没法排除"Lunch"、"Focus"这类无需计入统计的会议。要实现过滤需求，需要直接遍历日历中的会议项，逐个判断是否符合统计条件，再计算有效忙碌时长。

以下是修改后的完整代码，已实现关键词过滤功能：

Sub BlockMoreCalendarAppts()
    Dim myCalendar As Folder
    Dim calItems As Items
    Dim filteredItems As Items
    Dim appt As AppointmentItem
    Dim tDate As Date
    Dim d As Long
    Dim totalBusyMinutes As Long
    Dim workingDayStart As Date
    Dim workingDayEnd As Date
    Dim apptStart As Date
    Dim apptEnd As Date
    Dim excludeKeywords As Variant
    Dim keyword As Variant
    Dim isExcluded As Boolean
    
    ' 设置默认日历（可根据需要修改为指定日历）
    Set myCalendar = Session.GetDefaultFolder(olFolderCalendar)
    
    ' 定义需要排除的主题关键词
    excludeKeywords = Array("Lunch", "Focus")
    
    ' 定义工作时间范围（和原代码保持一致：9:30开始，时长7小时10分，即16:40结束）
    workingDayStart = #9:30:00 AM#
    workingDayEnd = workingDayStart + TimeValue("7:10:00")
    
    ' 检查未来0到5天
    For d = 0 To 5
        tDate = Date + d
        totalBusyMinutes = 0
        
        ' 筛选当天的会议项（排除全天事件，因为原代码统计的是时段会议）
        Set calItems = myCalendar.Items
        calItems.IncludeRecurrences = True
        calItems.Sort "[Start]"
        Set filteredItems = calItems.Restrict("[Start] >= '" & Format(tDate, "ddddd hh:mm AMPM") & "' AND [End] <= '" & Format(tDate + 1, "ddddd hh:mm AMPM") & "' AND [AllDayEvent] = False")
        
        ' 遍历每个会议项
        For Each appt In filteredItems
            isExcluded = False
            
            ' 检查是否包含排除关键词
            For Each keyword In excludeKeywords
                If InStr(1, appt.Subject, keyword, vbTextCompare) > 0 Then
                    isExcluded = True
                    Exit For
                End If
            Next keyword
            
            ' 如果不排除，计算该会议在工作时间内的时长
            If Not isExcluded Then
                apptStart = appt.Start
                apptEnd = appt.End
                
                ' 调整会议开始/结束时间，只统计工作时间内的部分
                apptStart = IIf(apptStart < tDate + workingDayStart, tDate + workingDayStart, apptStart)
                apptEnd = IIf(apptEnd > tDate + workingDayEnd, tDate + workingDayEnd, apptEnd)
                
                ' 如果调整后的结束时间晚于开始时间，累加时长
                If apptEnd > apptStart Then
                    totalBusyMinutes = totalBusyMinutes + DateDiff("n", apptStart, apptEnd)
                End If
            End If
        Next appt
        
        ' 计算总时长（小时）
        totalBusyHours = Round(totalBusyMinutes / 60, 2)
        
        ' 当有效忙碌时长超过5小时（300分钟）时创建全天忙碌预约
        If totalBusyMinutes >= 300 Then
            Dim oAppt As AppointmentItem
            Set oAppt = Application.CreateItem(olAppointmentItem)
            With oAppt
                .Subject = totalBusyHours & " hours of appt today"
                .Start = tDate
                .ReminderSet = False
                .Categories = "Full Day"
                .AllDayEvent = True
                .BusyStatus = olBusy
                .Save
            End With
        End If
    Next d
    
    Set myCalendar = Nothing
    Set calItems = Nothing
    Set filteredItems = Nothing
    Set appt = Nothing
    Set oAppt = Nothing
End Sub

关键修改说明： #

1. 直接遍历日历项：放弃FreeBusy方法，改用Items.Restrict筛选当天的会议，确保能获取每个会议的主题信息。
2. 关键词过滤逻辑：通过InStr函数（忽略大小写）检查会议主题是否包含指定关键词，包含则跳过统计。
3. 工作时间内时长计算：仅统计会议在设定的工作时间（9:30-16:40）内的部分，避免把非工作时段的会议时长计入。
4. 时长判断阈值：将原代码的CountOccurrences >= 60（60个5分钟时段=300分钟）替换为直接判断总分钟数≥300，逻辑更直观。

使用注意事项： #

• 若需要排除更多关键词，直接在excludeKeywords = Array("Lunch", "Focus")中添加即可，比如Array("Lunch", "Focus", "Break")。
• 若你的默认日历不是目标日历，可以修改Set myCalendar = Session.GetDefaultFolder(olFolderCalendar)为指定日历，例如通过Session.Folders("邮箱名称").Folders("自定义日历名称")获取。

内容的提问来源于stack exchange，提问作者Charlie