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
ProcessInbox PROCESS_ONLY_NEW_ITEMS_ON_NEW_MAIL_ARRIVED
ExitApplicationNewMail:
End Sub
Private Sub Application_Startup() ' Event that runs when Outlook starts
On Error GoTo ExitApplicationStartup ' Catch any unhandled errors
ProcessInbox PROCESS_ONLY_NEW_ITEMS_ON_STARTUP
ExitApplicationStartup:
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
NextItem:
        ' Update unread iteam count if the item was unread and deleted
        If (currentItemUnread And itemDeleted) Then
            newItemCount = newItemCount - 1
        End If
    Next
    ' Remove the new mail icon
    If ((REMOVE_NEW_MAIL_ICON_IF_NO_NEW_ITEMS_REMAIN) And (newItemCount > 0)) Then
        RemoveNewMailIcon ' You'll need to download
    End If
ExitProcessInbox:
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
    Else
        endDate = appointment.End
    End If
    If (endDate < Date) Then ' If the meeting occurs in the past just delete it
        meetingRequest.Delete
        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
        If (SEND_ACCEPT_RESPONSE_TO_ALL_DAY_APPOINTMENTS = True) Then
            appointment.Send
        End If
        ' Delete the request
        meetingRequest.Delete
        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
            meetingRequest.Delete
            itemDeleted = True
        Else
            ' 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
ExitProcessMeetingRequest:
    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].



Related