Outlook日历VBA空闲搜索：当日早间空闲识别异常求助

核心问题分析 #

程序约在11:30提前终止且TypeName(OLAppt)变为Nothing，大概率是因为遍历日历项时访问了已过期的空闲时段对应的无效Outlook对象，导致对象引用失效；同时代码未过滤已过期时段，错误地让无效逻辑干扰了后续有效时段的检测，最终返回“未找到空闲时段”。

具体修复步骤 #

1. 增加OLAppt对象空值判断 #

在遍历循环中先检查对象有效性，避免无效对象导致程序终止：

Dim OLAppt As Outlook.AppointmentItem
' 假设通过CalendarItems集合遍历日历项
For Each OLAppt In CalendarItems
    ' 跳过无效对象
    If OLAppt Is Nothing Then
        Continue For
    End If
    
    ' 后续空闲时段判断逻辑
Next OLAppt

2. 严格过滤已过期时段 #

在判断空闲前，直接跳过结束时间早于当前时间的过期时段：

Dim currentTime As Date
currentTime = Now()

' 时间过滤逻辑放在空闲判断前
If OLAppt.End <= currentTime Then
    Continue For
End If

3. 调整空闲搜索逻辑 #

用计数器和日期记录确保找到2个不同日期的有效空闲，避免提前退出：

Dim foundCount As Integer
Dim lastFoundDate As Date
foundCount = 0
lastFoundDate = DateSerial(1900, 1, 1) ' 初始化早日期

Do While foundCount < 2 And ' 保留你的遍历终止条件
    ' 先执行对象判断和时间过滤
    
    ' 检查当前空闲日期是否与已找到的不同
    If DateValue(OLAppt.Start) <> lastFoundDate Then
        ' 调用你的保存逻辑
        SaveFreeSlot OLAppt.Start, OLAppt.End
        foundCount = foundCount + 1
        lastFoundDate = DateValue(OLAppt.Start)
    End If
Loop

4. 优化搜索时间范围初始化 #

让搜索从当前时间之后开始，减少无效过期项的遍历：

Dim searchStart As Date
searchStart = DateAdd("n", 30, Now()) ' 从当前时间30分钟后开始，可按需调整

' 筛选未来的日历项
CalendarItems.IncludeRecurrences = True
CalendarItems.Sort "[Start]"
Set CalendarItems = CalendarItems.Restrict("[Start] >= '" & Format(searchStart, "ddddd hh:mm AMPM") & "'")

关键注意点 #

• 处理Outlook对象必须加Is Nothing判断，避免对象引用错误导致程序崩溃。
• 只关注当前时间之后的空闲时段，彻底排除过期项的干扰。
• 确保搜索逻辑会持续遍历直到找到2个符合要求的空闲，而非遇到无效项就返回无结果。

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