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.
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/
Also I cant seem to add blocking off time for recurruring appointments
Yeah,
I never added support for recurring, in part because its more complicated. If i have time, i will add it - basically, you need to check it see if its recurring and then copy the pattern. But this will not copy exceptions.
Looks great though only seems to work on certain appointment types so meetings I can add block out time before and after but not appointments added to the calendar?
If Item.MeetingStatus = olMeeting Or Item.MeetingStatus = olMeetingReceived Then
if you remove that line and the end if that goes with it, it will apply to all appointments.
Not sure where those lines are - i am using option 2 to manually add time before and after appointments and meetings
it should work on the manual macro - the automatic version checks for the items type, the manual method uses on the selected item in the calendar.
You can try changing this link to comment out as appointmentitem
Dim cAppt 'As AppointmentItem
how do i do that, can you paste the new code as i need it please
Your method works, but I meant like this:
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)
(-- snip--)
Ok i worked out how to comment out those two lines
But still doesnt work but think there are two different calendar types that I can't get it to work on.
Lots of my diary entries are these two types so would be really useful if I could get the code working to support them
Update, managed to get it working now, just hadnt added it to ribbon for different calandar views. It doesn't automatically add before and after times for recurring appointments/meetings but least i can go through and manually add it.
Hi - Is there an option for O365? i followed the steps and the macro didnt work. Any ideas?
This works with all version of Outlook desktop software. What happens when you try? Do you have macro security set to low?
Great macro, I find it very helpful in blocking off time so I don't have back-to-back meetings. One suggestion: the ability to not create duplicate meeting block if one already exist. It would be an IF statement to check if time has already been blocked with the same name, but I'm not sure what I would have it look for. Any suggestions? Thanks!
You'd need to do a search for the existing event in that time period with that subject.
Great macro, Diane! I love how the first macro makes this completely hands off. Would there be a way to add a check to avoid duplicate placeholders being created? In other words, if the placeholder times have been created previously, then don't add them again after a change (like accepting the invite). With the first, automatic macro in place, as soon as I get a meeting invitation the time before and after will be blocked off, which is great. If I don't get around to accepting the invite right away and other people start booking other meetings, I like that it shows my time as already blocked off without me needing to do anything. However, if I then accept the meeting, the macro will create another set of placeholder times next to the existing ones. If I tentatively accept at first, then fully accept, it created 3 placeholders, one for when it first arrived, then when I accepted it tentatively, and then again when I accept it fully. Every time the meeting's state changes a new pair is added. It would be great to check if Meeting Prep/Review Time Placeholder - <Main meeting name> already exists, then skip creation. Again,… Read more »
You'd need to do a look up - i have some code here I can add to it... i'll check and see if we can use conflicts to stop the creation too.