Geeky Bob

Using this Outlook VBA Macro

Over the years, I had noticed that I had appointments from years ago stuck in my calendar, so I wrote this Outlook VBA Macro to help keep my outlook calendar thinned-out.

Note: This macros deletes appointments and attachments from your Outlook calendar - make sure that you want to do this before running this macro.

By default the macro will:

Delete all appointments over a year old (except recurring appointments.)
Delete all attachments from 6-month-old appointments.
Delete large attachments from 2-month-old appointments.

You can alter these dates by adjusting the appropriate lines in the macro.

Outlook VBA Macro Example Code

Sub DeleteOldAppointments()

   Dim objOutlook As Outlook.Application
   Dim objNamespace As Outlook.NameSpace
   Dim objFolder As Outlook.MAPIFolder
   Dim objAppointement As Outlook.AppointmentItem
   Dim objAttachment As Outlook.Attachment
   Dim objNetwork As Object
   Dim lngDeletedAppointements As Long
   Dim lngCleanedAppointements As Long
   Dim lngCleanedAttachments As Long
   Dim blnRestart As Boolean
   Dim intDateDiff As Integer

   Set objOutlook = Application
   Set objNamespace = objOutlook.GetNamespace("MAPI")
   Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)

Here:

   blnRestart = False

   For Each objAppointement In objFolder.Items
      DoEvents
      intDateDiff = DateDiff("d", objAppointement.Start, Now)

      ' Delete year-old appointments.
      If intDateDiff > 365 And objAppointement.RecurrenceState = olApptNotRecurring Then
         objAppointement.Delete
         lngDeletedAppointements = lngDeletedAppointements + 1
         blnRestart = True

      ' Delete attachments from 6-month-old appointments.
      ElseIf intDateDiff > 180 And objAppointement.RecurrenceState = olApptNotRecurring Then
         If objAppointement.Attachments.Count > 0 Then
            While objAppointement.Attachments.Count > 0
               objAppointement.Attachments.Remove 1   Wend
            lngCleanedAppointements = lngCleanedAppointements + 1
        End If

      ' Delete large attachments from 60-day-old appointments.
      ElseIf intDateDiff > 60 Then
         If objAppointement.Attachments.Count > 0 Then
            For Each objAttachment In objAppointement.Attachments
               If objAttachment.Size > 500000 Then
                  objAttachment.Delete
                  lngCleanedAttachments = lngCleanedAttachments + 1
               End If
            Next
         End If
      End If
   Next

   If blnRestart = True Then GoTo Here

   MsgBox "Deleted " & lngDeletedAppointements & " appointment(s)." & vbCrLf & _
      "Cleaned " & lngCleanedAppointements & " appointment(s)." & vbCrLf & _
      "Deleted " & lngCleanedAttachments & " attachment(s)."

End Sub

Kev Judd 4/18/2011 8:13:24 AM

I know you posted this 3 years ago(!) but it this is EXCELLENT!! It works well as is and is simple even for someone like me with no programming skills to modify. 10/10 Thank you. I can now add Appointments from Excel AND delete all of the old appointments too!!

Kev Judd 4/18/2011 8:15:49 AM

This is EXCELLENT! It works as it is and is easy for a non-programmer like me to modify! I can now use Excel to ADD Appointments to my outlook calendar AND I can delete all appointments too! 10/10! Thank you!!!

Adri 5/11/2011 2:42:10 AM

this works fine too.

I want to modify it to get another functionality : delete older emails that have the same characteristicss set by rules, for example to keep only the last newsletters I receive.

I thought I could set up a rule and add "run the script" in it but I can't figure out why it doesn't work. here is the script:

Sub DeleteOldMails(objMail As Outlook.MailItem)

   Dim objOutlook As Outlook.Application
   Dim objNamespace As Outlook.NameSpace
   Dim objFolder As Outlook.MAPIFolder
   Dim objMail As Outlook.MailItem
   Dim objAttachment As Outlook.Attachment
   Dim objNetwork As Object
   Dim lngDeletedMails As Long
   Dim lngCleanedMails As Long
   Dim lngCleanedAttachments As Long
   Dim blnRestart As Boolean
   Dim intDateDiff As Integer

   Set objOutlook = Application
   Set objNamespace = objOutlook.GetNamespace("MAPI")
   Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

Here:

   blnRestart = False

   For Each objMail In objFolder.Items
      DoEvents
      intDateDiff = DateDiff("d", objMail.Start, Now)

      ' Delete 2-day-old mails.
      If intDateDiff > 2 Then
         objMail.Delete
         lngDeletedMails = lngDeletedMails + 1
         blnRestart = True

      End If
   Next

   If blnRestart = True Then GoTo Here

   'MsgBox "Deleted " & lngDeletedMailss & " mail(s)."

End Sub.

Any idea?

Thanks

Adri

Just a short, simple blog for Bob to share his thoughts.

Outlook Macro: Delete Old Appointments

Using this Outlook VBA Macro

Outlook VBA Macro Example Code

Related posts

Comments (3) -

Pingbacks and trackbacks (1)+