How to dynamically listen for _ItemAdd and ItemChange in all calendars in Outlook 2019 offline Deskt-CodePudding

I currently have the following VBA code to automatically push the body of Outlook appointments into MySQL. The two calendars listened to here in the example are (in reality I need many calendars and some may be created dynamically):

Default Calendar
MYCALENDAR2

Whenever a new appointment is entered into either calendar or changed in either calendar, the BODY of the appointment will be pushed automatically into MySQL table called report under the column called BODY.

This is the code I place under Project 1 -> Microsoft Outlook Objects -> ThisOutlookSession:

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

Private Sub Application_Startup()
 

    Set objNS = Application.GetNamespace("MAPI")

    
    'Set the folder and items to watch:
'    Set objWatchFolder = objNS.GetDefaultFolder(olFolderCalendar)
'    Set objItems = objWatchFolder.Items
        
    Dim objWatchFolder As Outlook.Folder
    Set objWatchFolder = objNS.GetDefaultFolder(olFolderCalendar)
    Set objItems = objWatchFolder.Items
    
    
    Dim objWatchFolder2 As Outlook.Folder
'    Set objWatchFolder2 = objNS.Folders("MYCALENDAR2").Folders("MYCALENDAR3").Folders("MYCALENDAR4").Folders("MYCALENDAR5").Folders("MYCALENDAR6")
    Set objWatchFolder2 = objNS.GetDefaultFolder(olFolderCalendar).Folders("MYCALENDAR2")
    Set objItems2 = objWatchFolder2.Items
    
    
    ' Set objItems2 = objWatchFolder.Items
    ' Set objItems2 = objNS.GetDefaultFolder(olFolderCalendar).Folders("MYCALENDAR2").Items
    
    
    
    Set objWatchFolder = Nothing
End Sub



Private Sub objItems_ItemAdd(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


Private Sub objItems_ItemChange(ByVal Item As Object)
 MsgBox "*** PROPERTIESS 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_ItemAdd(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


Private Sub objItems2_ItemChange(ByVal Item As Object)
 MsgBox "*** PROPERTIESS 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

The code is rather redundant.
In reality I have say 10 calendars (for example MYCALENDAR3, MYCALENDAR4 .. , MYCALENDAR9) and I may real time decide to add in new calendars.

How do I tidy up the code above so that it is more compact/flexible, plus can automatically cycle through all calendars and apply _ItemAdd and _ItemChange to each calendar automatically? I do not want to hard code actual calendar names, because in practice I may decide to add new calendars from time to time. I'd like the VB code to always cycle through all available calendars and listen automatically to all.

How should the above code be re-written exactly please? Thank you.

I tried this:

Set objWatchFolder2 = objNS.Folders("MYCALENDAR2").Folders("MYCALENDAR3").Folders("MYCALENDAR4").Folders("MYCALENDAR5").Folders("MYCALENDAR6")

and it did not work. Therefore I have commented it out in the code now.

QUESTION: How to dynamically listen for _ItemAdd and ItemChange in all calendars?

I use Outlook 2019 offline mode on Desktop. Windows 10 (64 bit).

PS: I have read some links about enumerate and Folder.DefaultItemType property, but I do not know how exactly to apply it to my code. . . (as following):

https://learn.microsoft.com/en-us/office/vba/outlook/how-to/navigation/enumerate-active-folders-in-the-calendar-view

https://learn.microsoft.com/en-us/office/vba/api/outlook.folder.defaultitemtype

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

ADDENDUM

I read the link provided: Run code when new email comes to any subfolder in a Shared Mailbox

It is for Mail, not Calendar. I tried to adopt the code from it to use for Outlook Calendar. This is the code I came up with (for Calendar):

Dim myRecipient As Outlook.Recipient
Dim oFolder As Outlook.Folder
Dim objOwner As Outlook.Recipient
Set objOwner = objNS.CreateRecipient("my_Shared_Mailibox")
objOwner.Resolve
Set oFolder = objNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
Set colFolders = New Collection
processFolder oFolder

In addition I have put the following in Class Module:

Option Explicit

Private OlFldr As Folder
Public WithEvents Items As Outlook.Items

'called to set up the object
Public Sub Init(f As Folder) ', sPath As String)
    Set OlFldr = f
    Set Items = f.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.CalendarItem Then
       Debug.Print "eMail '" & Item.Subject & "' was added to Folder '" & OlFldr.Name & _
              "'. Mailbox: '" & Item.Parent.Store & "'."
       'do sth with a email added...
  End If
End Sub

However when I run , I get this error message:

Run-time error '-2147352567(B80020009)': Outlook does not recognize one or more names

When I click "Debug". This following line is highlighted in yellow:

Set oFolder = objNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)

CodePudding user response：

First, you must to subscribe to each calendar folder in Outlook separately. The Outlook object mode doesn't provide any universal event to process all folders. Basically you need to iterate recursively over the tree of folders and check the Folder.DefaultItemType property which returns a constant from the OlItemType enumeration indicating the default Outlook item type contained in the folder. If the default type is olAppointmentItem then you deal with a calendar folder in Outlook and you need to subscribe to the events.

Second, be aware, any folder in Outlook may contain calendar items, so may be it makes sense to subscribe to all folders and check the item type in the event handler. The MessageClass property of Outlook items can help with that. It returns a string representing the message class for the Outlook item.

    Private Sub EnumerateFoldersInDefaultStore()
        Dim root As Outlook.Folder = TryCast(Application.Session.DefaultStore.GetRootFolder(), Outlook.Folder)
        EnumerateFolders(root)
    End Sub

    Private Sub EnumerateFolders(ByVal folder As Outlook.Folder)
        Dim childFolders As Outlook.Folders = folder.Folders

        If childFolders.Count > 0 Then

            For Each childFolder As Outlook.Folder In childFolders
                Debug.WriteLine(childFolder.FolderPath)
                EnumerateFolders(childFolder)
            Next
        End If
    End Sub

See how to Enumerate folders in MSDN.

CodePudding user response：

Based on Loop to set up watches on a selection of Outlook folders

Option Explicit

Dim colFolders3 As Collection '<< holds the clsFolder3 objects


Sub SetupFolderWatches3()

    'https://stackoverflow.com/questions/42257360/loop-to-set-up-watches-on-a-selection-of-outlook-folders
    
    Dim myCalendar As Folder
    
    Set colFolders3 = New Collection

    Set myCalendar = Session.GetDefaultFolder(olFolderCalendar)
    Debug.Print myCalendar.folderPath
    
    ' Include myCalendar 
    colFolders3.Add GetFolderObject3(myCalendar)
    Debug.Print "Added: " & myCalendar.folderPath
    
    ' Include subfolders of myCalendar
    processFolder myCalendar
    
End Sub


' function to create folder objects
'https://stackoverflow.com/questions/42257360/loop-to-set-up-watches-on-a-selection-of-outlook-folders
Function GetFolderObject3(foldr3 As Folder)
    Dim rv3 As New clsFolder3
    rv3.Init foldr3
    Set GetFolderObject3 = rv3
End Function


' https://stackoverflow.com/questions/2272361/can-i-iterate-through-all-outlook-emails-in-a-folder-including-sub-folders

Private Sub processFolder(ByVal oParent As Folder)

    Dim oFolder As Folder
    Dim i As Long
    
    If (oParent.Folders.count > 0) Then

        For i = 1 To oParent.Folders.count
            Set oFolder = oParent.Folders(i)
            
            Debug.Print oFolder.folderPath
            
            colFolders3.Add GetFolderObject3(oFolder)
            Debug.Print "Added: " & oFolder.folderPath
            processFolder oFolder
        Next
    End If
    
End Sub

In a class module named clsFolder3.

' https://stackoverflow.com/questions/42257360/loop-to-set-up-watches-on-a-selection-of-outlook-folders

Option Explicit

Private OlFldr3 As Folder
Public WithEvents Items3 As Items

'called to set up the object
Public Sub Init(f3 As Folder)
    Set OlFldr3 = f3
    Set Items3 = f3.Items
End Sub

Private Sub Items3_ItemAdd(ByVal Item As Object)
    Debug.Print "Item was added to Folder '" & OlFldr3.Name
    'MsgBox "Item was added to Folder '" & OlFldr3.Name
End Sub

In ThisOutlookSession.

Option Explicit
Private Sub Application_Startup()
    SetupFolderWatches3
End Sub