Outlook Macros Part 2: Cleaning Up Your Calendar

Continuing my brief departure from my normal IIS-related blogs and looking at Office Outlook again, today's blog looks at cleaning up your calendar. If you read my previous blog about Moving Emails Into Personal Folders, you would have read about my need to clean up my mail folders because I was running out of room on my Exchange server. A short time before that situation I had run into a different issue: I was looking through my calendar and I discovered that I had several meetings in my calendar that were from many years ago - in fact, I had a few meetings in my calendar that were well over ten years old!

The thought of searching through all of my calendar entries from the past several years and manually removing all of my old appointments did not sound like a great way to spend the day, so I decided to write a macro to clean up my old appointments.

The Macro

The main logic that I used for my macro can be broken down into three parts:

• If a non-reoccurring appointment is over a year old, it will be deleted.
• If a non-reoccurring appointment is over six months old, all attachments will be deleted from the appointment.
• If a non-reoccurring appointment is over two months old, any large (greater than ½ MB) attachments will be deleted from the appointment.

This macro has helped me tremendously to keep my calendar a little more manageable.

Copying some of the text from my previous blog entry, to create a macro in Outlook 2007, click on Tools, then Macro, then Visual Basic Editor. Once the Microsoft Visual Basic window opens, expand the project folders until you see ThisOutlookSession, then double-click that to open the Visual Basic Editor.

I am using Outlook 2010, so to create a macro I needed to click on the Developer tab on the ribbon, then click on the Visual Basic icon.

Once the Visual Basic editor opens, paste in the following code:

 Sub DeleteOldAppointments()

    ' See https://support.microsoft.com/kb/285202 for Outlook constants.

    ' Declare all variables.
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Dim objAppointment As Outlook.AppointmentItem
    Dim objAttachment As Outlook.Attachment
    Dim objVariant As Variant
    Dim lngDeletedAppointments As Long
    Dim lngCleanedAppointments As Long
    Dim lngCleanedAttachments As Long
    Dim intCount As Integer
    Dim intDateDiff As Integer

    ' Create an object for the Outlook application.
    Set objOutlook = Application
    ' Retrieve an object for the MAPI namespace.
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    ' Retrieve a folder object for the default calendar folder.
    Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)

    ' Loop through the items in the folder. NOTE: This has to
    ' be done backwards; if you process forwards you have to
    ' re-run the macro an inverese exponential number of times.
    For intCount = objFolder.Items.Count To 1 Step -1
        ' Retrieve an object from the folder.
        Set objVariant = objFolder.Items.Item(intCount)
        
        ' Allow the system to process. (Helps you to cancel the
        ' macro, or continue to use Outlook in the background.)
        DoEvents
        
        ' Filter objects for appointments/meetings.
        If objVariant.Class = olAppointment Then
            ' Create an appointment object from the current object.
            Set objAppointment = objVariant
        
            ' This is optional, but it helps me to see in the
            ' debug window where the macro is currently at.
            Debug.Print objAppointment.Start
            
            ' Calculate the difference in days between
            ' now and the date of the calendar object.
            intDateDiff = DateDiff("d", objAppointment.Start, Now)
            
            ' Look for year-old non-recurring appointments.
            If intDateDiff > 365 And objAppointment.RecurrenceState = olApptNotRecurring Then
                ' Delete the appointment.
                objAppointment.Delete
                ' Increment the count of deleted appointments.
                lngDeletedAppointments = lngDeletedAppointments + 1
                
            ' Delete attachments from 6-month-old non-recurring appointments.
            ElseIf intDateDiff > 180 And objAppointment.RecurrenceState = olApptNotRecurring Then
                ' Test if the calendar object has attachments.
                If objAppointment.Attachments.Count > 0 Then
                    ' Loop through the attachments collection.
                    While objAppointment.Attachments.Count > 0
                        ' Delete the current attachment.
                        objAppointment.Attachments.Remove 1
                        ' Increment the count of deleted attachments.
                        lngCleanedAttachments = lngCleanedAttachments + 1
                    Wend
                    ' Increment the count of cleaned appointments.
                    lngCleanedAppointments = lngCleanedAppointments + 1
                End If
            
            ' Delete large attachments from 60-day-old appointments.
            ElseIf intDateDiff > 60 Then
                ' Test if the calendar object has attachments.
                If objAppointment.Attachments.Count > 0 Then
                    ' Loop through the attachments collection.
                    For Each objAttachment In objAppointment.Attachments
                        ' Test if the attachment is too large.
                        If objAttachment.Size > 500000 Then
                            ' Delete the current attachment.
                            objAttachment.Delete
                            ' Increment the count of deleted attachments.
                            lngCleanedAttachments = lngCleanedAttachments + 1
                        End If
                    Next
                    ' Increment the count of cleaned appointments.
                    lngCleanedAppointments = lngCleanedAppointments + 1
                End If
            End If
        
        End If
        
   Next

    ' Display the number of calendar objects that were cleaned or deleted.
   MsgBox "Deleted " & lngDeletedAppointments & " appointment(s)." & vbCrLf & _
      "Cleaned " & lngCleanedAppointments & " appointment(s)." & vbCrLf & _
      "Deleted " & lngCleanedAttachments & " attachment(s)."

End Sub

When you run this macro, it will loop through all the non-reoccurring appointments in you calendar and remove any appointments or attachments based that match the criteria that I mentioned previously, and the macro will display the following message when it has completed:

(Note: I refer to "cleaning" an appointment as scanning through the appointment and looking for any attachments to remove.)

Customizations and Conclusions

Once again, I use a few Outlook constants in this macro, and you can look at https://support.microsoft.com/kb/285202 for a large list of Outlook constants that you can use if you want to customize the macro.

There are two primary customizations that I can think of that you might want to consider for this macro:

• You can easily change the time intervals that the macro uses - you'll notice that I chose 365, 180, and 60 days for the intervals in my version of the macro, but you might want to modify those for your specific situation.
• You can also change the "large" attachment size from 500,000 bytes (½ MB) to a size that is larger or smaller, depending on your mailbox situation.

I hope this helps. ;-]

Comments

• Anonymous
  August 29, 2010
  I have tried this in outlook 2003 and get an run time error 438 - any thoughts?

• Anonymous
  July 04, 2013
  robmcm, really great job. i was lookinf for a clear example to remove the double back up emails, and with your macro, now i understood how to do it. thanks and congratulations g

• Anonymous
  March 14, 2014
  Hi, Can you please help how to modify this to move/copy old entries into Archive Calendar and THEN delete?

• Anonymous
  September 23, 2014
  Hi and great work! just one question i need to amend this to just delete attachments and not alter any appointments at all can you please advise. many thanks

• Anonymous
  February 15, 2017
  This is quite an old post... but do you have something for recurring meetings?Thanks