Outlook: Adding Preparation/Postprocessing/Travel Time to an Appointment

When you're in a business environment, you most likely have to use Outlook for managing meetings. A common problem is that you've got a meeting scheduled with a couple of peers and you need some time extra. For example, you have to walk to a different building or you just want some preparation time, you need a time slot upfront and/or directly after the meeting.

In order to avoid beeing booked for a different meeting which adjoins the other one, you need to manually create appointments before and/or after the meeting. The other option is that your calendar shows a free time where there isn't one. Unfortunately, people avoid this tedious task and therefore, this situation is common practice.

I do have an elegant solution for this issue: an easy-to-reach button which adds appointment before and/or after a selected appointment.

To my great surprise, I found a ready-to use solution online.

You just need to press Alt-F11, paste the following script into your VBA-editor, and add a Quick Access Toolbar item to your Outlook. In case you need further help with the setup, please take a look at the screen-shots on my blog entry where I describe how I keep appointments on my calendar without accepting or declining them.

Public Sub AddPreparationAndPostprocessingTime()
  Dim coll As VBA.Collection
  Dim obj As Object
  Dim Appt As Outlook.AppointmentItem
  Dim Travel As Outlook.AppointmentItem
  Dim Items As Outlook.Items
  Dim Before&, After&
  Dim Category$, Subject$

  '1. Block minutes before and after the appointment
  Before = 15
  After = 0

  '2. Skip this if the default values never change
  Before = InputBox("Minutes before:", , Before)
  After = InputBox("Minutes after:", , After)

  If Before = 0 And After = 0 Then Exit Sub

  '3. Assign this category
  Category = "Gelbe Kategorie"

  Set coll = GetCurrentItems
  If coll.Count = 0 Then Exit Sub
  For Each obj In coll
    If TypeOf obj Is Outlook.AppointmentItem Then
      Set Appt = obj
      If TypeOf Appt.Parent Is Outlook.AppointmentItem Then
        Set Items = Appt.Parent.Parent.Items
      Else
        Set Items = Appt.Parent.Items
      End If

      '4. Use the main appointment's subject
      Subject = Appt.Subject

      If Before > 0 Then
        Set Travel = Items.Add
        Travel.Subject = "Preparation for: " + Subject
        Travel.Start = DateAdd("n", -Before, Appt.Start)
        Travel.Duration = Before
        Travel.Categories = Category
        Travel.Save
      End If

      If After > 0 Then
        Set Travel = Items.Add
        Travel.Subject = "Postprocessing: " + Subject
        Travel.Start = Appt.End
        Travel.Duration = After
        Travel.Categories = Category
        Travel.Save
      End If
    End If
  Next
End Sub


Private Function GetCurrentItems(Optional IsInspector As Boolean) As VBA.Collection
  Dim coll As VBA.Collection
  Dim Win As Object
  Dim Sel As Outlook.Selection
  Dim obj As Object
  Dim i&

  Set coll = New VBA.Collection
  Set Win = Application.ActiveWindow

  If TypeOf Win Is Outlook.Inspector Then
    IsInspector = True
    coll.Add Win.CurrentItem
  Else
    IsInspector = False
    Set Sel = Win.Selection
    If Not Sel Is Nothing Then
      For i = 1 To Sel.Count
        coll.Add Sel(i)
      Next
    End If
  End If
  Set GetCurrentItems = coll
End Function