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