How to event trigger when an appointment is added/changed in a custom calendar in Outlook 2016?-CodePudding

The following code will automatically send the BODY of the appointment (be it newly created or just modified) to MySQL (into the table called report, under the column called BODY). However it only works if the appointment is in the default calendar.

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

If I create or modify an appointment in a custom calendar (for example "My Test Calendar"), then nothing is triggered.

Question: How do I have the above code respond to objItems_ItemAdd or objItems_ItemModify for any custom calendar in addition to the default calendar please?

Thanks in advance.

I use offline Desktop version Outlook 2016 on Windows 10 (64 bit).

CodePudding user response：

You need to retrieve calendar folders and their Items collection to get the events fired. For example, here is what I see for the default calendar folder:

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

You can iterate over all folder in Outlook to find calendar folders by using the Folder.DefaultItemType property which will have the olAppointmentItem value for calendars.

Also you can get calendars using the navigation module in 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

See Enumerate Active Folders in the Calendar View for more information.

CodePudding user response：

You need to open the folder in question. Assuming "My Test Calendar" is a subfolder of the default calendar folder, your code would be

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