Outlook work calendar, integrate a (by sysadmin) locked calendar

Recently our sysadmin at work took another step at locking our calendar.
So naturally I had to find a way around their block.

If you are using Outlook app on the computer this could work for you.
If you are lucky then you can just copy paste and it will work fine, but if it does not work then you might need to know some VBA debugging.

This method makes a copy of your work calendar to another calendar that you create that is then shared with HA.
I recommend you create a new account on outlook.com to get a personal email and calendar account.
Using a pre-existing could work but if you have created different calendars inside the account then it will be more complex for the code to find the right spot to create new appointments at.

You need to enable VBA/macros for Outlook, follow this guide if you don’t know how to do it.
I have mine set to notify for all macros, and that is enough for this application.

Open the VBA explorer by pressing ALT+F11.
If you never done anything here before then it’s probably empty.
We need to add some code both in the ThisoutlookSession module but we also need to add a separate module.

Press the button to add a module:
(In my image I already have two modules, JsonConverter and Modul1).

Lets start with opening the ThisOutlookSession. double click on it.
This is the events listener.
Here we tell Outlook to do something when something happens.

This is the code we need, you can delete some of these events if you don’t want the code to run as often.
But the first event is when you send an email, the second one is when you get a reminder that you have a meeting in xx minutes, and the last one is when you open Outlook.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
End Sub

Private Sub Application_Reminder(ByVal Item As Object)
End Sub

Private Sub Application_Startup()
End Sub

At each of these times I make Outlook update my HA-work calendar. And here you can modify this as you like.
One thing that is very important is to check the spelling of Modul1.
Depending on the language of your install this will be different.
So the previous step was to create a module, in my case (and as you can see from the image) mine was called Modul1.
Make sure the spelling is correct.

Now we open the module we created.

Sub copy_calender()

        Dim olApp As Outlook.Application
        Dim olappt As Outlook.AppointmentItem
        Dim bAppOpened As Boolean
        Dim myNamespace As Outlook.NameSpace
        Dim myFolder As Outlook.Folder
        Dim objPane As Outlook.NavigationPane
        Dim objModule As Outlook.CalendarModule
        Dim CalFolder As Outlook.Folder

        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
        If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
        bAppOpened = False  ' Outlook was not already running, started it
            bAppOpened = True   ' Outlook was already running
        End If
        On Error GoTo 0
        Set objPane = Outlook.Application.ActiveExplorer.NavigationPane
        Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
' Below the code will loop through all calendars you have added to your Outlook app. 
' When it finds the correct calendar it skips out of the loop. 

        With objModule.NavigationGroups
            On Error Resume Next
            For g = 1 To .Count
                If Not CalFolder Is Nothing Then Exit For
                Set objGroup = .Item(g)
                For i = 1 To objGroup.NavigationFolders.Count
                    Set objNavFolder = objGroup.NavigationFolders.Item(i)
                    ' edit this line with the name of the email and what the name of the calendar is
                    If objNavFolder.Folder.FolderPath = "\\[email protected]\Kalender" Then 
                        Set CalFolder = objNavFolder.Folder
                        'MsgBox CalFolder
                        Exit For
                    End If
        End With

' Your HA-calendar should be fond when the code gets here.
' Now we need to get your main calendar and grab the next 14 days of appointments.

        Dim cAppt As AppointmentItem
        Dim objAppointment As AppointmentItem
        Dim NS As Outlook.NameSpace
        Set NS = Application.GetNamespace("MAPI")
        Set myNamespace = Application.GetNamespace("MAPI")
        tdystart = VBA.Format(Now, "Short Date")
        tdyend = VBA.Format(Now + 14, "Short Date")
        Set myAppointments = myNamespace.GetDefaultFolder(olFolderCalendar).Items
        myAppointments.Sort "[Start]"
        myAppointments.IncludeRecurrences = True
        Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
        While TypeName(currentAppointment) <> "Nothing"
        ' here it loops your work calendar, then the for each loop below loops your HA-calendar.
        ' if fnd remains false that means there is a new meeting that is not in your HA-calendar
            fnd = False
            For Each apt In CalFolder.Items
                If apt.Start = currentAppointment.Start And apt.Subject = currentAppointment.Subject And apt.End = currentAppointment.End Then 
                    fnd = True
                    Exit For
                ElseIf Now() - apt.Start > 30 Then
                    ' here I remove calendar entries in your HA-work calendar that is older than 30 days, meaning last months appointments. Shorten this if you are a busy person.
                End If
            Next apt
            If fnd = False Then
                ' add the new appointment to your HA-calendar.
                Set olappt = CalFolder.Items.Add
                With olappt
                    .Subject = currentAppointment.Subject
                    .Start = currentAppointment.Start
                    .Duration = currentAppointment.Duration
                    .Location = currentAppointment.Location
                    .Body = currentAppointment.Body
                End With
            End If
            Set currentAppointment = myAppointments.FindNext
End Sub

There is one line that needs to be edited, and that is the account and calendar name.
Here is what it looks like for me:

The green line is my HA-work calendar, the code block above has one line with: If objNavFolder.Folder.FolderPath = "\\[email protected]\Kalender" Then
This is your HA-work calendar.

The code will only look at 14 days at the time.
The code will delete events in your HA-calendar that is older than 30 days. So today, 2024-05-20 it deletes events that is older than 2024-04-20 (or whatever it becomes).
This is to make sure the looping of the HA-calendar does not take too much time.
I could probably do the same kind of loop as the other main calendar does, but for me it makes no difference.
Feel free to change it if you like.

So if everything works, the code should run rather quickly, you can press F5 to run it.
And you should be able to see all events mirrored in your new calendar, that you then can integrate in HA with no issues.

Don’t forget to press the save button in VBA explorer before you close Outlook.
I have done that mistake many many times…