如何在每次保存工作簿时创建Outlook日历条目？

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim olApp As Object
    Dim olItem As Object
    
    ' 创建Outlook应用程序对象
    Set olApp = CreateObject("Outlook.Application")
    
    ' 创建日历条目对象
    Set olItem = olApp.CreateItem(1) ' 1表示创建约会条目
    
    ' 设置日历条目的属性
    With olItem
        .Subject = "工作簿保存提醒" ' 日历条目的主题
        .Start = Now() ' 日历条目的开始时间
        .End = Now() ' 日历条目的结束时间
        .Location = "办公室" ' 日历条目的地点
        .Body = "请保存工作簿" ' 日历条目的内容
        .ReminderSet = True ' 是否设置提醒
        .ReminderMinutesBeforeStart = 15 ' 提前15分钟提醒
    End With
    
    ' 保存日历条目
    olItem.Save
    
    ' 释放对象
    Set olItem = Nothing
    Set olApp = Nothing
End Sub