Outlook VBA日历筛选异常求助：无法正确获取指定约会

问题背景 #

尝试用VBA筛选指定日期范围且主题包含BIB1500的Outlook日历约会，目的是给这些约会添加私人邮箱参会人同步到私人日历，但筛选结果异常：

• 当oItems.IncludeRecurrences = True时，所有条目计数均为2147483647（未有效过滤）
• 设为False时，日期范围内条目计数为0
  两种情况都无法输出约会的开始时间和主题

代码实现 #

Sub FindAppts()

Dim myStart As Date
Dim myEnd As Date
Dim oCalendar As Outlook.Folder
Dim oItems As Outlook.Items
Dim oItemsInDateRange As Outlook.Items
Dim oFinalItems As Outlook.Items
Dim oAppt As Outlook.AppointmentItem
Dim strRestriction As String

myStart = Date
myEnd = DateAdd("d", 3, myStart)

Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
      
'Construct filter for the next 3-day date range
strRestriction = "[Start] >= '" & _
Format$(myStart, "mm/dd/yyyy hh:mm AMPM") _
& "' AND [End] <= '" & _
Format$(myEnd, "mm/dd/yyyy hh:mm AMPM") & "'"
'Check the restriction string
Debug.Print strRestriction

Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
'Check if calendar is correct
Debug.Print "Calendar path " & oCalendar.FolderPath

Set oItems = oCalendar.Items
oItems.IncludeRecurrences = True 'or set as False
oItems.Sort "[Start]"
Debug.Print "All items " & oItems.Count

'Restrict the Items collection for the 3-day date range
Set oItemsInDateRange = oItems.Restrict(strRestriction)
oItemsInDateRange.Sort "[Start]"
Debug.Print "Items within date range " & oItemsInDateRange.Count

'Construct filter for Subject containing 'BIB1500'
Const PropTag  As String = "https://schemas.microsoft.com/mapi/proptag/"
strRestriction = "@SQL=" & Chr(34) & PropTag _
    & "0x0037001E" & Chr(34) & " like '%BIB1500%'"
'Restrict the last set of filtered items for the subject
Set oFinalItems = oItemsInDateRange.Restrict(strRestriction)
'Sort and Debug.Print final results
oFinalItems.Sort "[Start]"
Debug.Print "Final items " & oFinalItems.Count

For Each oAppt In oFinalItems
    Debug.Print oAppt.Start, oAppt.Subject
Next

Debug.Print "Finito"
End Sub

运行结果 #

当IncludeRecurrences=True时： #

Start:        11.08.2025
End:          14.08.2025
[Start] >= '08.11.2025 12:00 a.m.' AND [End] <= '08.14.2025 12:00 a.m.'
Calendar path \XXXX@oslomet.no\Kalender
All items 2147483647
Items within date range 2147483647
Final items 2147483647
Finito

当IncludeRecurrences=False时： #

Start:  11.08.2025
End:          14.08.2025
[Start] >= '08.11.2025 12:00 a.m.' AND [End] <= '08.14.2025 12:00 a.m.'
Calendar path \XXX@oslomet.no\Kalender
All items 80
Items within date range 0
Final items 0
Finito

运行环境 #

• Windows 10
• 挪威语版Microsoft 365 Apps for business（版本2507）

问题根因与修正方案 #

1. 日期格式区域不匹配 #

挪威语系统默认日期格式为dd.mm.yyyy，但代码中用mm/dd/yyyy格式化日期，导致实际日期11.08.2025被转换为08.11.2025（月日颠倒），筛选范围完全错误。
修正：改用Outlook通用的ISO日期格式yyyy-mm-dd，避免区域格式干扰。

2. 循环约会处理顺序错误 #

设置IncludeRecurrences = True时，必须先对Items集合排序，再设置该属性，原代码顺序颠倒，导致循环约会无法正确展开，出现异常计数。

3. 主题筛选语法冗余 #

无需直接使用MAPI属性标签，改用更直观的[Subject] LIKE '%BIB1500%'即可实现主题包含筛选。

修正后的代码 #

Sub FindAppts_Fixed()

Dim myStart As Date
Dim myEnd As Date
Dim oCalendar As Outlook.Folder
Dim oItems As Outlook.Items
Dim oItemsInDateRange As Outlook.Items
Dim oFinalItems As Outlook.Items
Dim oAppt As Outlook.AppointmentItem
Dim strRestriction As String

myStart = Date
myEnd = DateAdd("d", 3, myStart)

Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
      
' 使用ISO日期格式避免区域格式问题
strRestriction = "[Start] >= '" & Format$(myStart, "yyyy-mm-dd hh:mm:ss") & "' AND [End] <= '" & Format$(myEnd, "yyyy-mm-dd hh:mm:ss") & "'"
Debug.Print strRestriction

Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
Debug.Print "Calendar path " & oCalendar.FolderPath

Set oItems = oCalendar.Items
' 先排序，再开启循环约会包含
oItems.Sort "[Start]"
oItems.IncludeRecurrences = True
Debug.Print "All items " & oItems.Count

Set oItemsInDateRange = oItems.Restrict(strRestriction)
oItemsInDateRange.Sort "[Start]"
Debug.Print "Items within date range " & oItemsInDateRange.Count

' 简化主题筛选语句
strRestriction = "@SQL=" & Chr(34) & "Subject" & Chr(34) & " LIKE '%BIB1500%'"
Set oFinalItems = oItemsInDateRange.Restrict(strRestriction)
oFinalItems.Sort "[Start]"
Debug.Print "Final items " & oFinalItems.Count

For Each oAppt In oFinalItems
    Debug.Print oAppt.Start, oAppt.Subject
Next

Debug.Print "Finito"
End Sub

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