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
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