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.
Hi Diane - thank you so much for this, it's incredibly useful and I appreciate you sharing the script. I have a quick query if you have time to consider it.
I'm using the first/auto version, and I find that when I receive a meeting I'm getting duplicate time blocks - so the time blocks go in when the invite is first received (and the meeting is in my diary as tentative), but then when I respond/accept the meeting, I get another two time blocks added. So I end up with four in total (two before and two after).
Am I doing something incorrect with the script?
Thanks in advance for your help.
I'll test it (and update) - but I'm guessing it is this line - that is causing it to do it both when it arrives and when you reply. Or when it syncs back after accepting it. The best thing might be to check the status and only create if accepted.
If Item.MeetingStatus = olMeeting Or Item.MeetingStatus = olMeetingReceived Then
Thanks you for your response Diane. Does this mean changing the Item.MeetingStatus = olMeetingReceived to Item.MeetingResponse = olMeetingAccepted?
I haven't had a chance to test it yet, but either that or check to see if accepted, then create the appointments.
My company don't allow to change the Marco security level, is there another option, like power automat, to achive this?
Power automate might do it - I will look into it.
I want to create an appointment (manually) that is for the first available 30-min slot starting 5 days before an appointment - is this possible? I've spent about an hour googling your site and also actual google :) and I've not come up with anything I can use. I'm good at modifying existing code but I can't write my own, so if someone could point me to something similar in VBA that would also help!
Thank you, this is much better than "shorten meeting" option in Outlook.
In real life, you need buffer times both before and after meetings. It can be due to preparation, travel, etc.
Good morning,
Diane, can you send the most updated code for Automatically block off time before and after meetings
Duane
This is only version I have. Is it not working for you?
Hello Diane,
absolutely helpful script! It's my first touch to VBA scripts but I love it from the beginning. :-)
I splitted the TimeSpan to TimeSpanBefore and TimeSpanAfter because I want to have different slots here. Works nice. The calendar does not look nie because my time span is just 5 and 10 minutes so all looks scrambled. But this is how Outlook displays eveything and has nothing to do with your script for sure.
The only thing which does not work is the cleanup of old entries. I made a meeting in the past and it was created with surrounding buffer. But starting the cleanup results in "moved 0 message(s)" and I don't see why. Is there anything special I have to take care for?
Regards
Marco
Hi Diane, thank you so much.
My calendar now fully looks blue and it's hard to read what are actual meetings vs what is review/ prep time.
Is it possible to add color coding/ categorisation into this which makes it easier to glance meetings/ appointments?
Thanks
You can add .categories = "category name" to add a category to the appointments.
Thank you.
Can you use this for a calendar you have edit privileges on and not your default calendar? If so how
Yes, you just need to pull in the correct calendar. https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/