Microsoft Bob

Just a short, simple blog for Bob to share some tips and tricks.

Be sure to check out my non-technical blog at www.bobsbasement.net.

Month List

Outlook Macro: Delete Old Appointments

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
Posted: Sep 30 2008, 13:31 by Bob | Comments (3)
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: Office | VBA
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us

Comments (3) -

Kev Judd United Kingdom said:

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!!

# April 18 2011, 08:13

Kev Judd United Kingdom said:

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!!!

# April 18 2011, 08:15

Adri France said:

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

# May 11 2011, 02:42

Pingbacks and trackbacks (1)+

Comments are closed