Aggregate availability from multiple calendars

I just spent a couple of hours with Copilot and have come up with a VBA Macro solution that's working perfectly for me.

It works for adding, moving and deleting items, in the calendars for two IMAP accounts and making a "Busy" appointment in a third IMAP account.  It could easily be extended to any number of IMAP accounts, not sure about other types.

In the VBA code, the places to change the source emails are obvious, but there are three places to change to your target email.

Enabling Macros in Outlook

Open Outlook:

Access the Trust Center:

Go to File > Options.

• In the Outlook Options dialog, select Trust Center from the left pane.
• Open Trust Center Settings:
• Click the Trust Center Settings... button.

Enable Macros:

In the Trust Center dialog, select Macro Settings from the left pane.

Choose one of the following options:

• Disable all macros without notification: Macros are disabled without any notifications.
• Notifications for all macros: Macros are disabled, but you will get a notification each time you try to run a macro.
• Enable all macros (not recommended, potentially dangerous code can run): All macros are enabled. (This is not recommended due to security risks.)
• Disable all macros except digitally signed macros: Unsigned macros are disabled, and notifications are shown. Signed macros are enabled.

Click OK to save the settings.

What Happens on Each Startup if the Macro is Not Signed

If your macro is not signed and your macro settings are set to disable all macros except digitally signed macros or to notify for all macros, the following will happen on each startup:

Security Warning:

You will receive a security warning notification indicating that macros have been disabled. This is to prevent potentially harmful code from running.

Enabling Macros Manually:

You will need to manually enable macros each time you start Outlook. To do this, click the Enable Content button in the security warning notification.

Potential Security Risks:

Unsigned macros are considered potentially dangerous because they could contain malicious code. It's essential to ensure that the source of your macros is trusted.

Installing the VBA Code

Start Outlook and press Alt + F11 to open the VBA editor.

Create a New Module:

• In the VBA editor, locate the Project Explorer window (usually on the left side). If it's not visible, press Ctrl + R to open it.
• In the Project Explorer, find the project corresponding to your Outlook session (it should be labeled something like "VbaProject.OTM").
• Right-click on the project, select Insert, and then Module.

Paste the Code:

• Copy the provided VBA code and paste it into the new module.

Save the Project

• Save your VBA project by clicking the Save button or pressing Ctrl + S.

Signing the VBA Code

Create a Digital Certificate:

If you don't have a digital certificate, you can create a self-signed certificate:

Go to the Windows Start menu, search for Selfcert.exe, and run it.

In the Create Digital Certificate dialog, enter a name for the certificate (e.g., "OutlookVBA") and click OK.

(This didn't work for my, but there was an already installed certificate that did.)

Open the VBA Project Properties:

In the VBA editor, go to Tools > Digital Signature.

Choose a Digital Certificate:

In the Digital Signature dialog, click Choose.

Select the certificate you created (e.g., "OutlookVBA") and click OK.

Save and Close the VBA Project:

Save the VBA project by clicking the Save button or pressing Ctrl + S.

Close the VBA editor by clicking the X button or pressing Alt + Q.

Restart Outlook

Close Outlook and then reopen it to ensure the VBA code is loaded and the digital certificate is applied.

Here's the VBA code:

Private WithEvents Items1 As Outlook.Items
Private WithEvents Items2 As Outlook.Items
Private WithEvents Folder1 As Outlook.Folder
Private WithEvents Folder2 As Outlook.Folder

Private Sub Application_Startup()
    Dim ns As Outlook.NameSpace
    Dim imapCalendar1 As Outlook.Folder
    Dim imapCalendar2 As Outlook.Folder
    Set ns = Application.GetNamespace("MAPI")

    ' Set up for the first source email account
    Set imapCalendar1 = ns.Folders("email address removed for privacy reasons").Folders("Calendar")
    Set Items1 = imapCalendar1.Items
    Set Folder1 = imapCalendar1

    ' Set up for the second source email account
    Set imapCalendar2 = ns.Folders("email address removed for privacy reasons").Folders("Calendar")
    Set Items2 = imapCalendar2.Items
    Set Folder2 = imapCalendar2
End Sub

Private Sub Folder1_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
    HandleBeforeItemMove Item, MoveTo
End Sub

Private Sub Folder2_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
    HandleBeforeItemMove Item, MoveTo
End Sub

Private Sub HandleBeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder)
    On Error Resume Next
    Dim ns As Outlook.NameSpace
    Dim destCalendar As Outlook.Folder
    Dim copiedAppointment As Outlook.AppointmentItem
    Dim entryID As String
    
    If MoveTo = "Deleted Items" Then
        ' Item is being deleted
        If TypeOf Item Is Outlook.AppointmentItem Then
            entryID = Item.UserProperties("CopyID").Value
            If entryID <> "" Then
                Set ns = Application.GetNamespace("MAPI")
                ' Change "Destination Calendar" to the name of your destination calendar
                Set destCalendar = ns.Folders("email address removed for privacy reasons").Folders("Calendar")

                ' Find the copied appointment by EntryID
                Set copiedAppointment = ns.GetItemFromID(entryID)

                If Not copiedAppointment Is Nothing Then
                    copiedAppointment.Delete
                End If
            End If
        End If
    End If
    On Error GoTo 0
End Sub

Private Sub Items1_ItemAdd(ByVal item As Object)
    If TypeOf item Is Outlook.AppointmentItem Then
        CopyAppointmentToAnotherCalendar item
    End If
End Sub

Private Sub Items2_ItemAdd(ByVal item As Object)
    If TypeOf item Is Outlook.AppointmentItem Then
        CopyAppointmentToAnotherCalendar item
    End If
End Sub

Private Sub Items1_ItemChange(ByVal item As Object)
    If TypeOf item Is Outlook.AppointmentItem Then
        UpdateAppointmentInAnotherCalendar item
    End If
End Sub

Private Sub Items2_ItemChange(ByVal item As Object)
    If TypeOf item Is Outlook.AppointmentItem Then
        UpdateAppointmentInAnotherCalendar item
    End If
End Sub

Private Sub CopyAppointmentToAnotherCalendar(App As Outlook.AppointmentItem)
    On Error Resume Next
    Dim ns As Outlook.NameSpace
    Dim destCalendar As Outlook.Folder
    Dim newAppointment As Outlook.AppointmentItem

    Set ns = Application.GetNamespace("MAPI")
    ' Change "Destination Calendar" to the name of your destination calendar
    Set destCalendar = ns.Folders("email address removed for privacy reasons").Folders("Calendar")

    Set newAppointment = destCalendar.Items.Add(olAppointmentItem)
    With newAppointment
        .Start = App.Start
        .End = App.End
        .Subject = "Busy"
        .ReminderSet = False ' Set reminder to None
        ' Uncomment the lines below to copy additional appointment details
        ' .Location = App.Location
        ' .Body = App.Body
        ' .RequiredAttendees = App.RequiredAttendees
        ' .OptionalAttendees = App.OptionalAttendees
        ' .AllDayEvent = App.AllDayEvent
        ' .BusyStatus = App.BusyStatus
        ' .Categories = App.Categories
        If App.IsRecurring Then
            Dim pattern As Outlook.RecurrencePattern
            Set pattern = App.GetRecurrencePattern
            Dim newPattern As Outlook.RecurrencePattern
            Set newPattern = newAppointment.GetRecurrencePattern
            newPattern.RecurrenceType = pattern.RecurrenceType
            newPattern.Interval = pattern.Interval
            ' Handle other recurrence settings here
        End If
        .Save
        ' Save the EntryID of the new appointment to link it
        Dim userProperty As Outlook.userProperty
        Set userProperty = App.UserProperties.Add("CopyID", olText)
        userProperty.Value = newAppointment.entryID
        App.Save
    End With
    On Error GoTo 0
End Sub

Private Sub UpdateAppointmentInAnotherCalendar(App As Outlook.AppointmentItem)
    Dim ns As Outlook.NameSpace
    Dim destCalendar As Outlook.Folder
    Dim copiedAppointment As Outlook.AppointmentItem
    Dim entryID As String

    On Error Resume Next
    entryID = App.UserProperties("CopyID").Value
    If entryID <> "" Then
        Set ns = Application.GetNamespace("MAPI")
        ' Change "Destination Calendar" to the name of your destination calendar
        Set destCalendar = ns.Folders("email address removed for privacy reasons").Folders("Calendar")
        
        ' Find the copied appointment by EntryID
        Set copiedAppointment = ns.GetItemFromID(entryID)

        If Not copiedAppointment Is Nothing Then
            With copiedAppointment
                If App.IsRecurring Then
                    Dim pattern As Outlook.RecurrencePattern
                    Set pattern = App.GetRecurrencePattern
                    Dim newPattern As Outlook.RecurrencePattern
                    Set newPattern = copiedAppointment.GetRecurrencePattern
                    newPattern.RecurrenceType = pattern.RecurrenceType
                    newPattern.Interval = pattern.Interval
                    ' Handle other recurrence settings here
                Else
                    .Start = App.Start
                    .End = App.End
                End If
                .Save
            End With
        End If
    End If
    On Error GoTo 0
End Sub