Automatically Add Travel Time to Calendar

I use these macros not for travel time, but to add prep and follow up time to meetings (and also in case we need a little more time to finish up) but they serve the same purpose: to block off time on the calendar so no one can invite you to a meeting too close to another meeting.

The first macro is automatic. It watches the calendar folder and when a new meeting is added, it creates busy appointments before and after the meeting to block the time off for meeting prep or travel time. This macro works only with meetings, not appointments.

If you prefer to add the time manually, the second macro on the page blocks off time before and after the selected appointment or meeting.

These macros use a set time for the added appointments, in this case 30 minutes, but you could just as easily use an input box to enter the time specific to a meeting or a userform to select from a list of times.

September 13 2018: Edited macro so it will create travel time appointments for both meetings you create and those you are invited to. Note that it will create the events when the meeting invitation arrives and is added to the calendar as Tentative. It will not remove the events if you decline the meeting.

' Add to ThisOutlookSession
Option Explicit
Private WithEvents CalendarItems As Items
Dim myCalendar As Outlook.Folder

Private Sub Application_Startup()
  Dim objNS As NameSpace
  Set objNS = Application.Session
   
  Set myCalendar = objNS.GetDefaultFolder(olFolderCalendar)
  Set CalendarItems = myCalendar.Items

  Set objNS = Nothing
End Sub

Private Sub CalendarItems_ItemAdd(ByVal Item As Object)
Dim TimeSpan As Long

'how much time do you want to block (in minutes)
 TimeSpan = 30

'If Item.MeetingStatus = olMeeting Then
If Item.MeetingStatus = olMeeting Or Item.MeetingStatus = olMeetingReceived Then
    On Error Resume Next
  
Dim oAppt As AppointmentItem
Set oAppt = Application.CreateItem(olAppointmentItem)

With oAppt
    .Subject = "Meeting Prep Time " & Item.Subject    '30 minutes before
    .StartUTC = Item.StartUTC - TimeSpan / 1440
    .Duration = TimeSpan
    .BusyStatus = olBusy
    .ReminderSet = False
    .Save
End With

Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
    .Subject = "Meeting Review Time " & Item.Subject
    .Start = Item.End
' use number for duration if you are using a different length here
    .Duration = TimeSpan
    .BusyStatus = olBusy
    .ReminderSet = False
    .Save
End With
End If
End Sub

Manually add travel time

Add this macro the a new module and create a button for it on the Quick Access Toolbar. To use, select an appointment and click the button.

Sub BlockOffTime()
    Dim objApp As Outlook.Application
    Set objApp = Application
   ' On Error Resume Next
  
Dim oAppt As AppointmentItem
Dim cAppt As AppointmentItem
  
Set cAppt = objApp.ActiveExplorer.Selection.Item(1)
Set oAppt = Application.CreateItem(olAppointmentItem)
'      MsgBox cAppt.StartUTC
With oAppt
    .Subject = "Meeting Prep Time"
    '30 minutes before
    .StartUTC = cAppt.StartUTC - 0.020833
    .Duration = 30
    .BusyStatus = olBusy
    .ReminderSet = False
    .Save
End With

Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
    .Subject = "Meeting Review Time"
    .Start = cAppt.End
    .Duration = 30
    .BusyStatus = olBusy
    .ReminderSet = False
    .Save
End With

Set cAppt = Nothing
  
End Sub

Remove Past 'Time Block' Appointments

While it is fairly easy to use Instant Search or a list view to remove these meeting from your calendar, a simple macro can remove all previous meetings added to block off time.

Sub DeletePasteBlockTime()
 
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.NameSpace
    Dim objSourceFolder As Outlook.MAPIFolder
    Dim objDestFolder As Outlook.MAPIFolder
    Dim objVariant As Variant
    Dim lngMovedItems As Long
    Dim intCount As Integer
     
    Set objOutlook = Application
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
      
    For intCount = objSourceFolder.Items.Count To 1 Step -1
        Set objVariant = objSourceFolder.Items.Item(intCount)
        DoEvents
        If objVariant.Subject = "Meeting Prep Time" Or objVariant.Subject = "Meeting Review Time" Then
            If objVariant.Start < Now Then
              objVariant.Delete
               
              'count the # of items moved
               lngMovedItems = lngMovedItems + 1
 
            End If
        End If
    Next
     
    ' Display the number of items that were moved.
    MsgBox "Moved " & lngMovedItems & " messages(s)."
Set objDestFolder = Nothing
End Sub

How to use the Macro

First: You will need macro security set to low during testing.

To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security. If Outlook tells you it needs to be restarted, close and reopen Outlook. Note: after you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

Now open the VBA Editor by pressing Alt+F11 on your keyboard.

To use the macro code in ThisOutlookSession:

1. Expand Project1 and double click on ThisOutlookSession.
2. Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)

Application_Startup macros run when Outlook starts. If you are using an Application_Startup macro you can test the macro without restarting Outlook by clicking in the first line of the Application_Startup macro then clicking the Run button on the toolbar or pressing F8.

To put the code in a module:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

More information as well as screenshots are at How to use the VBA Editor.