Outlook VBA

Annoying Appointments

If you work in an office that uses Outlook you are undoubtedly flooded with a barrage of appointments that you don't care about in the least. Co-workers feel the need to flood your calendar with all kinds of personal appointments that at best waste your time and at worst pop-up pointless reminders or block your free/busy status.

I wrote a little VBA code to take care of several common annoyances:

-Automatically accept all-day appointments (or automatically delete them by flipping one variable)

-Change the free/busy status on all-day appointments to "free", for the people too stupid to set it to free or think that because they're busy everyone else must be too

-Remove reminders from all-day appointments, man are those annoying

-Outright delete appointments that occur in the past, including repeating ones

The Code

I was going to write a fancy tutorial with pictures but instead I'll just assume you know how to launch the Visual Basic editor in Outlook or are smart enough to ask the Google how to do so.

' If you don't know beans about programming that's cool

' Here are the things that are safe to change to customize how this works

' The names are relatively friendly and it should make sense what they do

' Only change the stuff on the right of the equal sign and you'll be fine

Private Const ADD_NEW_APPOINTMENTS_TO_CALENDAR As Boolean = True ' True means new appointments will be added to the calendar, don't know why you'd want this false but it's an option

Private Const SEND_ACCEPT_RESPONSE_TO_ALL_DAY_APPOINTMENTS As Boolean = False ' True means an acceptance response will be sent to all day appointments

Private Const PROCESS_ONLY_NEW_ITEMS_ON_STARTUP = False ' True means only new items are processed read items are not; False means every item in the inbox is checked

Private Const PROCESS_ONLY_NEW_ITEMS_ON_NEW_MAIL_ARRIVED = True ' True means only new items are processed, read items are not; False means every item in the inbox is checked

Private Const REMOVE_NEW_MAIL_ICON_IF_NO_NEW_ITEMS_REMAIN = True ' True means the new mail icon will be removed if there are no unread items in the inbox

Private Sub Application_NewMail() ' Event that runs when new mail arrives

On Error GoTo ExitApplicationNewMail ' Catch any unhandled errors



End Sub

Private Sub Application_Startup() ' Event that runs when Outlook starts

On Error GoTo ExitApplicationStartup ' Catch any unhandled errors



End Sub

Private Sub ProcessInbox(newItemsOnly As Boolean)

Dim objItem As Outlook.MailItem

Dim inbox As MAPIFolder

Dim inboxItem As Object

Dim newItemCount As Integer

Dim itemDeleted As Boolean

Dim currentItemUnread As Boolean

newItemCount = 0

' If something bad happens opening the mailbox then bail

On Error GoTo ExitProcessInbox

' Look for unread items

Set inbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

For Each inboxItem In inbox.Items

' Keep track of unread item count

itemDeleted = False

If (inboxItem.UnRead) Then

currentItemUnread = True

newItemCount = newItemCount + 1

End If

' Within the loop, if something bad happens go to the next item

On Error GoTo NextItem

DoEvents ' Let Outlook do stuff while this loop is executing

If (newItemsOnly And (currentItemUnread)) Or (newItemsOnly = False) Then

' This If/ElseIf block checks for the Class of the inbox item and calls the appropriate handler

If (inboxItem.Class = olMeetingRequest) Then

itemDeleted = ProcessMeetingRequest(inboxItem)

' ElseIf --- in future posts we'll address other message types, when/if that time comes we'll paste the code here

End If

End If


' Update unread iteam count if the item was unread and deleted

If (currentItemUnread And itemDeleted) Then

newItemCount = newItemCount - 1

End If


' Remove the new mail icon


RemoveNewMailIcon ' You'll need to download

End If


End Sub

Private Function ProcessMeetingRequest(meetingRequest As MeetingItem)

Dim appointment As AppointmentItem

Dim endDate As Date

Dim itemDeleted As Boolean

itemDeleted = False

' Stuff happens, for example if an appointment is dismissed without being read it causes GetAssociatedAppointment to explode

On Error GoTo ExitProcessMeetingRequest

' Grab a reference to the actual appointment

Set appointment = meetingRequest.GetAssociatedAppointment(ADD_NEW_APPOINTMENTS_TO_CALENDAR)

If (appointment.RecurrenceState <> olApptNotRecurring) Then

Dim rp As RecurrencePattern

Set rp = appointment.GetRecurrencePattern()

endDate = rp.PatternEndDate


endDate = appointment.End

End If

If (endDate < Date) Then ' If the meeting occurs in the past just delete it


itemDeleted = True

ElseIf ((appointment.AllDayEvent = True) Or (appointment.Duration >= 1440)) Then ' Take care of all day appointments - 99% of the time these are vacation notices

' Deal with people who accidently (or passive-aggressively) block your calendar

appointment.BusyStatus = olFree

' Same for people who put reminders on everything

appointment.ReminderSet = False

' Accept the appointment

appointment.Respond olMeetingAccepted, True, True



End If

' Delete the request


itemDeleted = True

Else ' Regular appointment

' Delete annoying appointments like "so and so is going to the bathroom from 1:30-2:00"

If (appointment.BusyStatus = olFree) Then


itemDeleted = True


' If you ever wanted to write a function to automatically accept/decline other appointment types this would be the place to do it

End If

End If


ProcessMeetingRequest = itemDeleted

End Function

If you want the RemoveNewMailIcon function to work you need to import NeoClearIcon.bas which I blatantly lifted from [web archive link].