Also See...

You should also check out my non-technology blog at:

http://www.bobsbasement.net/

Outlook Macro: Export Appointments to TSV File

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

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 (4) RSS comment feed |
  • Currently 0/5 Stars.
  • 1
  • 2
  • 3
  • 4
  • 5
Filed under: Office | VBA
Social Bookmarks: E-mail | Kick it! | DZone it! | del.icio.us