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:
- Expand Project1 and double click on ThisOutlookSession.
- 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:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor.