在 Outlook 2016 的自定义日历中添加/更改约会时如何触发事件？答案

【问题标题】：How to trigger event when an appointment is added/changed in a custom calendar?在 Outlook 2016 的自定义日历中添加/更改约会时如何触发事件？
【发布时间】：2022-10-06 01:05:54
【问题描述】：

以下代码将自动将约会的 BODY（无论是新创建的还是刚刚修改的）发送到 MySQL（到名为 report 的表中，在名为 BODY 的列下）。但是，它仅在约会在默认日历中时才有效。

Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
Private WithEvents objItems2 As Outlook.Items

Private Sub Application_Startup()
 
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace(\"MAPI\")

\'Set the folder and items to watch:
Set objWatchFolder = objNS.GetDefaultFolder(olFolderCalendar)
Set objItems = objWatchFolder.Items
Set objItems2 = objWatchFolder.Items

Set objWatchFolder = Nothing
End Sub


Private Sub objItems_ItemAdd(ByVal Item As Object)

\' Your code goes here
\' MsgBox \"Message subject: \" & Item.Subject & vbCrLf & \"Message sender: \" & Item.SenderName & \" (\" & Item.SenderEmailAddress & \")\"
\' https://www.slipstick.com/developer/itemadd-macro

 MsgBox \"*** PROPERTIES of olFolderCalendar ***\" & vbNewLine & _
        \"Subject: \" & Item.Subject & vbNewLine & _
        \"Start: \" & Item.Start & vbNewLine & _
        \"End: \" & Item.End & vbNewLine & _
        \"Duration: \" & Item.Duration & vbNewLine & _
        \"Location: \" & Item.Location & vbNewLine & _
        \"Body: \" & Item.Body & vbNewLine & _
        \"Global Appointment ID: \" & Item.GlobalAppointmentID
        
  send2mysql Item
  
Set Item = Nothing
End Sub


Private Sub objItems2_ItemChange(ByVal Item As Object)


 MsgBox \"*** PROPERTIES of olFolderCalendar ***\" & vbNewLine & _
        \"Subject: \" & Item.Subject & vbNewLine & _
        \"Start: \" & Item.Start & vbNewLine & _
        \"End: \" & Item.End & vbNewLine & _
        \"Duration: \" & Item.Duration & vbNewLine & _
        \"Location: \" & Item.Location & vbNewLine & _
        \"Body: \" & Item.Body & vbNewLine & _
        \"Global Appointment 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
    Set cn = New ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim strConn As String
    strConn = \"Driver={MySQL ODBC 8.0 ANSI Driver};Server=localhost; Database=thairis; UID=root; PWD=root\"
    cn.Open strConn
        
        updSQL = \"INSERT INTO report (BODY) VALUES (\" & Item.Body & \"\')\"
        
        cn.Execute updSQL
          
MsgBox updSQL
    MsgBox \"Done\"

End Sub

如果我在自定义日历（例如“我的测试日历”）中创建或修改约会，则不会触发任何内容。

问题：除了默认日历之外，我如何让上述代码响应任何自定义日历的 objItems_ItemAdd 或 objItems_ItemModify？

提前致谢。

我在 Windows 10（64 位）上使用离线桌面版 Outlook 2016。

这回答了你的问题了吗？ Adding Listeners to different folders in Outlook

标签： vba outlook

【解决方案1】：

您需要打开有问题的文件夹。假设“我的测试日历”是默认日历文件夹的子文件夹，您的代码将是

Set objItems2 = objNS.GetDefaultFolder(olFolderCalendar).Folders("My Test Calendar").Items

【讨论】：

【解决方案2】：

您需要检索日历文件夹及其 Items 集合以触发事件。例如，这是我看到的默认日历文件夹：

'Set the folder and items to watch:
Set objWatchFolder = objNS.GetDefaultFolder(olFolderCalendar)
Set objItems = objWatchFolder.Items

您可以使用 Folder.DefaultItemType 属性遍历 Outlook 中的所有文件夹以查找日历文件夹，该属性将具有日历的 olAppointmentItem 值。

您还可以使用 Outlook 中的导航模块获取日历：

Dim WithEvents objPane As NavigationPane 
 
Private Sub EnumerateActiveCalendarFolders() 
 Dim objModule As CalendarModule 
 Dim objGroup As NavigationGroup 
 Dim objFolder As NavigationFolder 
 Dim intCounter As Integer 
 
 On Error GoTo ErrRoutine 
 
 ' Get the NavigationPane object for the 
 ' currently displayed Explorer object. 
 Set objPane = Application.ActiveExplorer.NavigationPane 
 
 ' Get the CalendarModule object, if one exists, 
 ' for the current Navigation Pane. 
 Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar) 
 
 ' Iterate through each NavigationGroup contained 
 ' by the CalendarModule. 
 For Each objGroup In objModule.NavigationGroups 
 ' Iterate through each NavigationFolder contained 
 ' by the NavigationGroup. 
 For Each objFolder In objGroup.NavigationFolders 
 ' Check if the folder is selected. 
 If objFolder.IsSelected Then 
 intCounter = intCounter + 1 
 End If 
 Next 
 Next 
 
 ' Display the results. 
 MsgBox "There are " & intCounter & " selected calendars in the Calendar module." 
 
EndRoutine: 
 On Error GoTo 0 
 Set objFolder = Nothing 
 Set objGroup = Nothing 
 Set objModule = Nothing 
 Set objPane = Nothing 
 intCounter = 0 
 Exit Sub 
 
ErrRoutine: 
 MsgBox Err.Number & " - " & Err.Description, _ 
 vbOKOnly Or vbCritical, _ 
 "EnumerateActiveCalendarFolders" 
End Sub

有关更多信息，请参阅Enumerate Active Folders in the Calendar View。

【讨论】：