Outlook Macro: Export Appointments to TSV File

30. September 2008 Bob Office , VBA Comments (0)

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 export a list of all my appointments to a tab-separated (TSV) file so that I could open it in Microsoft Excel and analyze all of my appointments. (After writing this macro, I wrote my Delete Old Appointments macro to delete old appointments.)

Outlook VBA Macro Example Code

Sub ExportAppointmentsToTsvFile()

   Dim objOutlook As Outlook.Application
   Dim objNamespace As Outlook.NameSpace
   Dim objFolder As Outlook.MAPIFolder
   Dim objAppointement As Outlook.AppointmentItem
   Dim objNetwork As Object
   Dim objFSO As Object
   Dim objFile As Object
   Dim strUserName As String

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

   Set objNetwork = CreateObject("WScript.Network")

   strUserName = objNetwork.UserName

   If InStr(strUserName, "\") = 0 Then
      strUserName = objNetwork.UserDomain & "\" & strUserName
   End If

   Set objFSO = CreateObject("Scripting.FileSystemObject")
   Set objFile = objFSO.CreateTextFile("c:\outlook-calendar.tsv")

   objFile.WriteLine "UserName" & vbTab & _
      "AppointementStart" & vbTab & _
      "AppointementEnd" & vbTab & _
      "AppointementRecurrenceState" & vbTab & _
      "AppointementSubject" & vbTab & _
      "AppointementSize" & vbTab & _
      "AppointementUnRead" & vbTab & _
      "AppointementLocation"

   For Each objAppointement In objFolder.Items
      DoEvents
      objFile.WriteLine strUserName & vbTab & _
      objAppointement.Start & vbTab & _
      objAppointement.End & vbTab & _
      objAppointement.RecurrenceState & vbTab & _
      objAppointement.Subject & vbTab & _
      objAppointement.Size & vbTab & _
      objAppointement.UnRead & vbTab & _
      objAppointement.Location
   Next

   MsgBox "Done!"

End Sub

Outlook Macro: Delete Old Appointments

30. September 2008 Bob Office , VBA Comments (3)

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