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 SubManually 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 SubHow 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.
Jan says
Hi Diane,
I get a run-time error and "Array index out of bounds"
Han says
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.
Diane Poremsky says
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
Han says
Thanks you for your response Diane. Does this mean changing the Item.MeetingStatus = olMeetingReceived to Item.MeetingResponse = olMeetingAccepted?
Diane Poremsky says
I haven't had a chance to test it yet, but either that or check to see if accepted, then create the appointments.
Remco says
My company don't allow to change the Marco security level, is there another option, like power automat, to achive this?
Diane Poremsky says
Power automate might do it - I will look into it.
Amanda says
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!
Kamil Dursun says
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.
Duane says
Good morning,
Diane, can you send the most updated code for Automatically block off time before and after meetings
Duane
Diane Poremsky says
This is only version I have. Is it not working for you?
Marco Mueller says
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
Khaled says
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
Diane Poremsky says
You can add .categories = "category name" to add a category to the appointments.
Khaled says
Thank you.
Jacqui Davis says
Can you use this for a calendar you have edit privileges on and not your default calendar? If so how
Diane Poremsky says
Yes, you just need to pull in the correct calendar. https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
Alan says
Also I cant seem to add blocking off time for recurruring appointments
Diane Poremsky says
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.
Alan says
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?
Diane Poremsky says
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.
Alan says
Not sure where those lines are - i am using option 2 to manually add time before and after appointments and meetings
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 SubDiane Poremsky says
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
Alan says
how do i do that, can you paste the new code as i need it please
Diane Poremsky says
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--)
Alan says
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
Alan says
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.
Lilian says
Hi - Is there an option for O365? i followed the steps and the macro didnt work. Any ideas?
Diane Poremsky says
This works with all version of Outlook desktop software. What happens when you try? Do you have macro security set to low?
Mike OC says
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!
Diane Poremsky says
You'd need to do a search for the existing event in that time period with that subject.
Mike O says
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, great job and thank you for posting this!
Diane Poremsky says
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.
Egle says
Hey, is there any update on this?
Jason Holmes says
Hi Diane, This is Great! I've used this many times, but recently got a new laptop running O2016. I am getting a "Compile Error: Only Valid in Object Module" error. WithEvents in the line "Private WithEvents CalendarItems As Items". I have other Macros and this is the first in "ThisOutlookSession". Any thoughts?
Diane Poremsky says
it definitely needs to be in thisoutlooksession - that line at the top (if you had other macros in thisoutlooksession).
Jonathan DeJesus says
So sorry. I know this an older post. The first Macro works great!! So thank you. But it only works when I create a meeting. Is there a way this also runs when I get invited to a meeting. I'm using Outlook 2017. Thanks again!!
Diane Poremsky says
It should work for both. I'll check on it.
Ok... olMeeting is only for meetings you create. if you add a condition for olmeeting received, it works.
If Item.MeetingStatus = olMeeting Or Item.MeetingStatus = olMeetingReceived Then
The only issue: They are added when you receive the meeting and its on the calendar as tentative. if you decline, the travel times are not removed.
Jonathan DeJesus says
No worries, better to remove unneeded time later than not have the time blocked when needed.
Thank you Thank you Thank you!!
Wes says
Oh my! What have you/I done? First Macro ever and I'm loving it! Thanks for teaching an old dog a new trick.
Stephanie says
This is so awesome. I am using the 2nd version of the code where I've added a macro button so it only happens to select meetings.
I'm wondering if there is a way to make these default to a category color I've already established and also show as "out of office"?
Thank you!
Diane Poremsky says
This is where you'd set OOF - change it to olOutOfOffice
.BusyStatus = olBusy
to assign a specific category, add this line after the busy status line:
.categories = "category name"
if you want to pick it up from the meeting or appointment, use
.categories = item.categories
Jeffrey Suijskens says
Hi Diane,
For the second part of the code - amazing - it works like a charm.
Is there any way of adding the title of the meeting to the prep- and review time?
As it functions double as a reminder of what to prep/review.
Also, how can I add a timeselection for the prep/review time?
Kind regards,
Jeffrey
Diane Poremsky says
For the subject, use
.Subject = "Meeting Prep Time " & item.subject
This sets the time you want to block -
'how much time do you want to block (in minutes)
TimeSpan = 30
you could use an input box to enter the minutes.
TimeSpan = InputBox("How much lead time do you need?")
(move it after if item.meetingstatus... otherwise it will come up for every appointment, not just meetings)
This will use the same time for before and after. if you want different times, add the line a second time, after the first one is created but before the second. (If you always cut the same amt off the review, say 5 min less than the prep time, you can use .Duration = TimeSpan - 5 for the review duration.)
Jeffrey Suijskens says
Hi Diane,
Currently I have below code and I would like to check the inputbox for "X" or "Cancel" and then kill the routine if nothing has been implemented.
Also to stop running if value = 0 minutes.
Also is it possible to alter the inputbox? Now its huge as opposed to the tiny input there is to provide.
Thanks in advance for your feedback!
Sub BlockOffTravelTime()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)
TimeSpan = InputBox("How much travel time is required?")
' MsgBox cAppt.StartUTC
With oAppt
.Subject = "Reistijd: heenreis " & cAppt.Subject
.Body = cAppt.Body
.Location = cAppt.Location
' 1440 makes sure the prep appointment is before the selected appointment
.StartUTC = cAppt.StartUTC - TimeSpan / 1440
.Duration = TimeSpan
.BusyStatus = olOutOfOffice
.Categories = "Travel Time"
.ReminderSet = False
.Save
End With
Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
.Subject = "Reistijd: Terugreis " & cAppt.Subject
.Location = cAppt.Location
.Start = cAppt.End
.Duration = TimeSpan
.BusyStatus = olOutOfOffice
.Categories = "Travel Time"
.ReminderSet = False
.Save
End With
Set cAppt = Nothing
End Sub
Diane Poremsky says
Try this - after the timespan line:
TimeSpan = InputBox("How much travel time is required?", 0)
Add
If TimeSpan is "" or TimeSpan = 0 Then
Exit sub
End if
or this:
TimeSpan = InputBox( "How much travel time is required?", "Block Time", 0)
If TimeSpan = 0 Then
Exit Sub
End If
Diane Poremsky says
Also, you can't change the size of the inputbox.
Jeffrey Suijskens says
The first one worked perfectly. Thank you!
Dwayne Baraka says
Hi Diane,
I'm having trouble with that code, and I'd really like it to work! Are you expecting that to work with the latest version of Outlook?
I'm getting the following error from the second line of the code (at "WithEvents CalendarItems As Items") when I try to drop it into ThisSessionOutlook.
Compile Error
Invalid attribute in Sur or Function
Any hints?
Best Regards,
Dwayne.
Diane Poremsky says
I have tested all of the code in 2013, and much of the code in 2016. If you have other macros, thatline needs to be at the top of ThisOutlookSession.
YRobins says
Hi Diane,
is there any existing code to bring out the map it tool to a tool bar that I created. It has all my quick access icons plus vb macros.
thank you
Yvonne
Diane Poremsky says
No, I'm not aware of any. Sorry.
YRobins says
Hi Diane when I try print articles from your website, they always cut of at least one half inch on the left margin. Any suggestions on how to remedy this/
Diane Poremsky says
I'm assuming it's dropping the side bars and the actual article is being cut off... i will need to check it. I know it works correctly when i send to onenote but i never print to paper. :)