Mass Outlook Calendar Cleanup

Over the last few weeks the company that I work for have been migrating from Google Apps over to Microsoft 365 for mail/calendar/contacts and unified messaging etc. This has not been without it’s challenges. Some have which have been fairly bizarre. This week I was approached by a member of our department who had somehow managed to end up with 10,000+ appointments of the same title in his calendar. We set about trying to remove them on mass using the Outlook GUI, but soon realised this would take a very long time. Which is when I put together the following snippet of VBA:

NB: This code ‘takes no prisoners, and straight deletes the appointments matching the criteria you pass it. This wouldn’t be easy to undue if you ran with incorrect parameters. I’d advise adding a break point and testing a few before letting it hit your entire calendar folder.

Dim myNameSpace As NameSpace
Dim myCalendar As Folder
Dim myAppts As Items
Dim myAppt As AppointmentItem
Dim i As Integer

Sub purge_cal()
    Set myNameSpace = Outlook.Application.GetNamespace("MAPI")
    Set myCalendar = myNameSpace.GetDefaultFolder(olFolderCalendar)

    Set myAppts = myCalendar.Items
    i = 0
    For Each myAppt In myAppts
        If myAppt.Subject = "" Then
            i = i + 1
            Debug.Print "Deleting " & myAppt.Subject
            myAppt.Delete

        End If
    Next
        Debug.Print i & " calendar items deleted"
End Sub