向个人日历添加自定义公司节假日，避免重复条目生成

我已经修改了VBS脚本，但多次运行后，脚本会为所有已定义的日期创建重复的日历条目，不清楚为何无法定位特定日历日期下的重复主题。当前使用的脚本代码如下：

Const olFolderCalendar = 9
Const olAppointmentItem = 1
Const olOutOfOffice = 3
CRLF = Chr(13) & Chr(10)

' Initialize Outlook
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar)
Set objDictionary = CreateObject("Scripting.Dictionary")

' Add holiday entries (modify as needed)
objDictionary.Add DateSerial(2023, 11, 23), "Thanksgiving Day"
objDictionary.Add DateSerial(2023, 11, 24), "Day After Thanksgiving Day"
objDictionary.Add DateSerial(2023, 12, 25), "Christmas Day"
objDictionary.Add DateSerial(2024, 1, 1), "New Years Day"
objDictionary.Add DateSerial(2024, 1, 15), "Martin Luther King Day"
objDictionary.Add DateSerial(2024, 5, 27), "Memorial Day"
objDictionary.Add DateSerial(2024, 7, 4), "Independence Day"
objDictionary.Add DateSerial(2024, 11, 28), "Thanksgiving Day"
objDictionary.Add DateSerial(2024, 11, 29), "Day After Thanksgiving Day"
objDictionary.Add DateSerial(2024, 12, 25), "Christmas Day"
objDictionary.Add DateSerial(2025, 1, 1), "New Years Day"

' Iterate through the dictionary
For Each dtmHolidayDate In objDictionary.Keys
    strHolidayName = objDictionary.Item(dtmHolidayDate)

    ' Check if an appointment with the same subject already exists
    Set objExistingHoliday = objCalendar.Items.Find("[Subject] = '" & strHolidayName & "' AND [Start] = '" & Month(dtmHolidayDate) & "/" & Day(dtmHolidayDate) & "/" & Year(dtmHolidayDate) & "'")
    If objExistingHoliday Is Nothing Then
        ' Create a new appointment item
        Set objHoliday = objOutlook.CreateItem(olAppointmentItem)
        With objHoliday
            .Subject = strHolidayName
            .Start = dtmHolidayDate
            .End = dtmHolidayDate
            .Categories = "Company Holidays"
            .AllDayEvent = True
            .ReminderSet = False
            .BusyStatus = olOutOfOffice
            .Save
        End With
    End If
Next

核心问题 #

脚本里的Find方法日期匹配逻辑失效：手动拼接的Month/Day/Year格式和Outlook内部存储的日期格式不兼容，导致每次运行都找不到已存在的条目，从而重复创建。另外，原脚本中全天事件的End值设置不符合Outlook规范，也可能干扰匹配结果。

修复后的完整脚本（已汉化） #

Const olFolderCalendar = 9
Const olAppointmentItem = 1
Const olOutOfOffice = 3

' 初始化Outlook
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar)
Set objDictionary = CreateObject("Scripting.Dictionary")

' 添加节假日条目（可按需修改）
objDictionary.Add DateSerial(2023, 11, 23), "感恩节"
objDictionary.Add DateSerial(2023, 11, 24), "感恩节后一天"
objDictionary.Add DateSerial(2023, 12, 25), "圣诞节"
objDictionary.Add DateSerial(2024, 1, 1), "新年"
objDictionary.Add DateSerial(2024, 1, 15), "马丁·路德·金纪念日"
objDictionary.Add DateSerial(2024, 5, 27), "阵亡将士纪念日"
objDictionary.Add DateSerial(2024, 7, 4), "独立日"
objDictionary.Add DateSerial(2024, 11, 28), "感恩节"
objDictionary.Add DateSerial(2024, 11, 29), "感恩节后一天"
objDictionary.Add DateSerial(2024, 12, 25), "圣诞节"
objDictionary.Add DateSerial(2025, 1, 1), "新年"

' 遍历所有节假日条目
For Each dtmHolidayDate In objDictionary.Keys
    strHolidayName = objDictionary.Item(dtmHolidayDate)
    
    ' 生成符合Outlook要求的日期格式，同时转义主题中的单引号避免语法错误
    strStartDate = FormatDateTime(dtmHolidayDate, vbShortDate)
    strSafeSubject = Replace(strHolidayName, "'", "''")
    
    ' 构建精准的过滤条件：匹配主题、当天范围内的起始时间、且是全天事件
    strFilter = "[Subject] = '" & strSafeSubject & "' AND [Start] >= '" & strStartDate & "' AND [Start] < '" & DateAdd("d", 1, strStartDate) & "' AND [AllDayEvent] = True"
    
    Set objExistingHoliday = objCalendar.Items.Find(strFilter)
    
    ' 确认没有匹配条目时再创建新日历项
    If objExistingHoliday Is Nothing Then
        Set objHoliday = objOutlook.CreateItem(olAppointmentItem)
        With objHoliday
            .Subject = strHolidayName
            .Start = dtmHolidayDate
            .End = DateAdd("d", 1, dtmHolidayDate) ' 全天事件的End需设为次日0点，Outlook会正确显示
            .Categories = "公司节假日"
            .AllDayEvent = True
            .ReminderSet = False
            .BusyStatus = olOutOfOffice
            .Save
        End With
    End If
Next

关键修复点 #

1. 日期格式兼容：用FormatDateTime生成系统区域兼容的短日期，替代手动拼接的格式，确保Outlook能正确识别日期条件。
2. 主题转义：用Replace处理主题中的单引号，避免Find语句出现语法错误。
3. 全天事件匹配：添加[AllDayEvent] = True过滤条件，同时用日期范围[Start] >= ... AND [Start] < ...匹配全天事件的起始时间（全天事件的Start为当天0点）。
4. End值修正：将全天事件的End设为次日0点，符合Outlook的全天事件规范，避免潜在的匹配问题。

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