如何让Outlook代码响应自定义日历的约会添加/修改事件

原代码仅能将默认日历中新增/修改的约会正文同步到MySQL的report表BODY字段，但自定义日历（如"My Test Calendar"）的操作无法触发同步。以下是修改后的代码，可实现监控所有日历文件夹的ItemAdd和ItemChange事件：

Option Explicit
Private objNS As Outlook.NameSpace
Private colCalendarItems As Collection ' 存储所有日历的Items对象

' 自定义类模块：CalendarItemEvents，用于绑定单个日历的事件
' 需先插入类模块，命名为CalendarItemEvents
' 类模块代码如下：
' Option Explicit
' Public WithEvents objItems As Outlook.Items
' Private Sub objItems_ItemAdd(ByVal Item As Object)
'     HandleCalendarItem Item
' End Sub
' Private Sub objItems_ItemChange(ByVal Item As Object)
'     HandleCalendarItem Item
' End Sub

Private Sub Application_Startup()
    Dim objFolder As Outlook.Folder
    Dim objCalendarEvents As CalendarItemEvents
    
    Set objNS = Application.GetNamespace("MAPI")
    Set colCalendarItems = New Collection
    
    ' 遍历所有日历文件夹
    For Each objFolder In objNS.GetDefaultFolder(olFolderCalendar).Parent.Folders
        If objFolder.DefaultItemType = olAppointmentItem Then
            Set objCalendarEvents = New CalendarItemEvents
            Set objCalendarEvents.objItems = objFolder.Items
            colCalendarItems.Add objCalendarEvents
        End If
    Next objFolder
    
    Set objFolder = Nothing
    Set objCalendarEvents = Nothing
End Sub

' 统一处理日历项的新增/修改事件
Private Sub HandleCalendarItem(ByVal Item As Object)
    MsgBox "*** 日历项属性 ***" & vbNewLine & _
           "日历名称: " & Item.Parent.Name & vbNewLine & _
           "主题: " & Item.Subject & vbNewLine & _
           "开始时间: " & Item.Start & vbNewLine & _
           "结束时间: " & Item.End & vbNewLine & _
           "时长: " & Item.Duration & vbNewLine & _
           "地点: " & Item.Location & vbNewLine & _
           "正文: " & Item.Body & vbNewLine & _
           "全局约会ID: " & Item.GlobalAppointmentID
    
    send2mysql Item
    
    Set Item = Nothing
End Sub

Sub send2mysql(ByVal Item As Object)
    Dim updSQL As String
    Dim cn As ADODB.Connection
    Dim strConn As String
    
    ' 处理正文中的单引号，避免SQL语法错误
    Dim safeBody As String
    safeBody = Replace(Item.Body, "'", "''")
    
    strConn = "Driver={MySQL ODBC 8.0 ANSI Driver};Server=localhost; Database=thairis; UID=root; PWD=root"
    Set cn = New ADODB.Connection
    
    On Error GoTo Cleanup
    cn.Open strConn
    
    updSQL = "INSERT INTO report (BODY) VALUES ('" & safeBody & "')"
    cn.Execute updSQL
    
    MsgBox updSQL
    MsgBox "同步完成"
    
Cleanup:
    If Err.Number <> 0 Then
        MsgBox "同步失败: " & Err.Description
    End If
    If cn.State = adStateOpen Then cn.Close
    Set cn = Nothing
End Sub

关键修改说明 #

1. 新增类模块：创建CalendarItemEvents类模块，用于绑定单个日历文件夹的ItemAdd和ItemChange事件——单个WithEvents变量仅能监控一个文件夹，通过集合可批量管理多个日历的事件绑定。
2. 遍历所有日历：在Application_Startup中遍历默认日历的父文件夹下所有子文件夹，筛选出约会类型的日历文件夹，为每个文件夹创建事件绑定对象并加入集合。
3. 统一事件处理：将原有的两个事件处理逻辑合并到HandleCalendarItem过程，避免代码冗余。
4. SQL语法防护：新增Replace(Item.Body, "'", "''")处理正文中的单引号，避免因特殊字符导致SQL语句报错。

注意事项 #

• 需先在Outlook VBA编辑器中插入类模块，命名为CalendarItemEvents，并将注释中的类模块代码粘贴进去。
• 确保已安装MySQL ODBC 8.0 ANSI驱动，若驱动版本或名称不同，需修改strConn中的驱动名称。
• 重启Outlook后宏才会生效，且需在Outlook宏设置中启用宏（路径：文件→选项→信任中心→信任中心设置→宏设置）。

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