Travel Time for Meetings


I was checking tweets this afternoon and came across an interesting one from Brian Kahrs. Here’s what Brian said: Why doesn’t @Microsoft Outlook ask to block “transportation time” when setting up a meeting? I may have a 1:15, but can’t meet from 1-1:15. Brian makes a really good point. Meetings don’t reflect the travel time. Of course Brian could simply pad the meeting time to include his travel time, but that would be confusing to the other meeting participants. They’d have to know that the meeting times were padded to include travel time and they’d have to know what Brian’s travel time is in order for them to mentally adjust the meeting start/end times accordingly. Not good. Another solution Brian could employ is to manually create appointments on either side of the actual meeting to block off the travel time to and from the meeting location. That would eliminate any confusion for the other meeting attendees, but Brian has to remember to create those two additional appointment for every meeting he creates.

I can’t answer Brian’s question on why Microsoft hasn’t included this feature. What I can do is offer Brian a workaround. I’m not going to call it a solution because it’s imperfect. The workaround is to use a script to detect when Brian adds a meeting to his calendar and give him the opportunity to block-off travel time on either side of it. Here’s how it works.

  1. Brian creates or accepts a meeting.
  2. The script detects the fact that a meeting has been added to his calendar.
  3. The script displays a dialog-box asking Brian if he wants to schedule travel time for this appointment.
  4. If Brian answers “yes”, then the script prompts him for the number of minutes of travel.
  5. Brian enters the number of minutes.
  6. The script creates two appointments, one on either side of the meeting. Each of these appointments blocks off the number of minutes Brian entered in step #5.

Using the example Brian gave in his tweet, if he created a meeting that ran from 1:15 to 2:15, then the script would create an appointment from 1:00 – 1:15 for Brian to travel to the meeting and another from 2:15 – 2:30 for Brian to return from the meeting.

As I noted earlier this isn’t a complete solution because it’s not perfect. In this context “not perfect” means that it doesn’t handle everything it needs to. If the meeting time changes, then Brian will have to manually deal with the two travel appointments. Ditto if the meeting is canceled. The workaround doesn’t handle different travel times either. Brian may be able to get to the meeting in 15 minutes, but he may know that at 2:15 it’ll take him 30 minutes to get back. Or perhaps this is the last meeting of the day and Brian won’t be returning and therefore doesn’t need to block travel time after the meeting. A true solution would handle all of these issues.

Here’s the code that Brian will need to use the workaround.

Dim WithEvents olkCalendar As Outlook.Items

Private Sub Application_Quit()
    Set olkCalendar = Nothing
End Sub

Private Sub Application_Startup()
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
End Sub

Private Sub olkCalendar_ItemAdd(ByVal Item As Object)
    Const SCRIPT_NAME = "Schedule Travel Time"
    Dim olkTravel1 As Outlook.AppointmentItem, _
        olkTravel2 As Outlook.AppointmentItem, _
        intMinutes As Integer
    If Item.MeetingStatus = olMeeting Then
        If msgbox("Do you need to schedule travel time for this meeting?", vbQuestion + vbYesNo, SCRIPT_NAME) = vbYes Then
            intMinutes = InputBox("How many minutes each way?", SCRIPT_NAME, 15)
            If intMinutes > 0 Then
                Set olkTravel1 = Application.CreateItem(olAppointmentItem)
                With olkTravel1
                    .Subject = "Travel to Meeting: " & Item.Subject
                    .Start = DateAdd("n", intMinutes * -1, Item.Start)
                    .End = Item.Start
                    .Categories = Item.Categories
                    .BusyStatus = olBusy
                    .Save
                End With
                Set olkTravel2 = Application.CreateItem(olAppointmentItem)
                With olkTravel2
                    .Subject = "Travel from Meeting: " & Item.Subject
                    .Start = Item.End
                    .End = DateAdd("n", intMinutes, Item.End)
                    .Categories = Item.Categories
                    .BusyStatus = olBusy
                    .Save
                End With
            End If
        End If
    End If
    Set olkTravel1 = Nothing
    Set olkTravel2 = Nothing
End Sub

Here’s how to add the code to Outlook.

Outlook 2003 and Earlier
1. Start Outlook
2. Click Tools > Macro > Visual Basic Editor
3. If not already expanded, expand Microsoft Office Outlook Objects and click on ThisOutlookSession
4. Copy the code from the Code Snippet box and paste it into the right-hand pane of
5. Outlook’s VB Editor window
6. Edit the code as needed. I included comment lines wherever something needs to or can change
7. Click the diskette icon on the toolbar to save the changes
8. Close the VB Editor
9. Click Tools > Macro > Security
10. Set the Security Level to Medium
11. Close Outlook
12. Start Outlook
13. Outlook will display a dialog-box warning that ThisOutlookSession contains macros and asking if you want to allow them to run. Say yes.

Outlook 2007
1. Start Outlook
2. Click Tools > Macro > Visual Basic Editor
3. If not already expanded, expand Microsoft Office Outlook Objects and click on ThisOutlookSession
4. Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook’s VB Editor window
5. Edit the code as needed. I included comment lines wherever something needs to or can change
6. Click the diskette icon on the toolbar to save the changes
7. Close the VB Editor
8. Click Tools > Trust Center
9. Click Macro Security
10. Set Macro Security to “Warnings for all macros”
11. Click OK
12. Close Outlook
13. Start Outlook. Outlook will display a dialog-box warning that ThisOutlookSession contains macros and asking if you want to allow them to run. Say yes.

I hope Brian finds this useful.

Revisions.

I create this revision after a couple of readers asked for a version that would block travel time for appointments as well as meetings. The original version only handles meetings. Since the code keys on items being added to the calendar, it has to have a way to discriminate between real meetings/appointments and the appointments it adds for travel time. The original code solved that by checking to see if the new item is a meeting. If it is, then add travel time. If not, then ignore it. Without that kind of check the code would get locked in an infinite loop as the travel time appointments would be seen as new items which would cause the code to prompt for travel time and add new appointments, which would be seen as new items, and so on, and so on, ad infinitum. To prevent that, this version uses a category called “Travel”. If the appointment belongs to the “Travel” category, then the code won’t prompt for travel time since it sees the appointment as a travel time entry. If the new item does not belong to the “Travel” category, then the code will prompt for travel time.

Use the instructions from the original post to add this code to Outlook. If you have the original code in place, then either delete it or overwrite it with this version. You don’t want to have both versions in place.

Dim WithEvents olkCalendar As Outlook.Items

Private Sub Application_Quit()
    Set olkCalendar = Nothing
End Sub

Private Sub Application_Startup()
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
End Sub

Private Sub olkCalendar_ItemAdd(ByVal Item As Object)
    Const SCRIPT_NAME = "Schedule Travel Time"
    'On the next line change the category name as desired.  The code will ignore any meeting or appointment assigned to this category.
    Const CATEGORY_NAME = "Travel"
    Dim olkTravel1 As Outlook.AppointmentItem, _
        olkTravel2 As Outlook.AppointmentItem, _
        intMinutes As Integer, _
        strNoun As String
    If InStr(1, Item.Categories, CATEGORY_NAME) = 0 Then
        strNoun = IIf(Item.MeetingStatus = olMeeting, "meeting", "appointment")
        If MsgBox("Do you need to schedule travel time for this " & strNoun & "?", vbQuestion + vbYesNo, SCRIPT_NAME) = vbYes Then
            intMinutes = InputBox("How many minutes each way?", SCRIPT_NAME, 15)
            If intMinutes > 0 Then
                Set olkTravel1 = Application.CreateItem(olAppointmentItem)
                With olkTravel1
                    .Subject = "Travel to " & StrConv(strNoun, vbProperCase) & ": " & Item.Subject
                    .Start = DateAdd("n", intMinutes * -1, Item.Start)
                    .End = Item.Start
                    .Categories = IIf(Len(Item.Categories) > 0, Item.Categories & ", Travel", "Travel")
                    .BusyStatus = olBusy
                    .Save
                End With
                Set olkTravel2 = Application.CreateItem(olAppointmentItem)
                With olkTravel2
                    .Subject = "Travel from " & StrConv(strNoun, vbProperCase) & ": " & Item.Subject
                    .Start = Item.End
                    .End = DateAdd("n", intMinutes, Item.End)
                    .Categories = IIf(Len(Item.Categories) > 0, Item.Categories & ", Travel", "Travel")
                    .BusyStatus = olBusy
                    .Save
                End With
            End If
        End If
    End If
    Set olkTravel1 = Nothing
    Set olkTravel2 = Nothing
End Sub
Advertisements

51 comments on “Travel Time for Meetings

  1. David, I’m having a compile error, can you please help? First, I’d like to thank you so much for this solution and for continuing to support it through this medium even though it has been so long, it says a lot. Please view my code below, can you identify anything wrong with it? I just copied and pasted it into my outlook as described, I’m using the latest version of Outlook which I downloaded through Office 365.

    Image of code and error can be seen here: http://www.carlosandteam.com/images/compile-error.png

    Thanks again for your attention.

    Carlos

    • Hi, Carlos.

      Thanks! That’s very kind of you.

      I don’t see anything wrong with the code. My best guess is that the copy and paste didn’t work properly. Please delete the code from Outlook. Once you’ve done that, copy the code again and paste it into Notepad. Then copy it from Notepad and paste it into Outlook. That should eliminate any extraneous, unprintable characters.

    • You were right, David! Something was off with the copy/paste. I did try notepad initially and that didn’t seem to clean it up. I tried a bunch of other stuff after your reply and almost gave up. Eventually I just removed all indentations manually from the script and boila, it worked! Thank you!

  2. More than half a decade on, and AFAIK there’s still no built-in feature for this. Love your work David. This is great!

    In case anyone’s interested, I’ve made a couple of tweaks to suit my purposes that others may find useful.

    1. Rather than asking if the user would like to apply travel time, it determines this automatically if the “Show As:” is “Out of office” on the original appointment

    2. Travel created as Out of Office.

    3. Travel reminders removed

    4. Sensitivity (privacy) and Importance copied to travel from original appointment

    5. If reminder is set on original appointment, the Travel time each way is now taken from the reminder time (ie when reminder pops up, time to leave! This can be manually adjusted later), If no reminder set, continues to prompt.

    (And as code duplication was starting to occur, re-factored the appointment creation code into a new sub).

    (Also noticed the CATEGORY_NAME constant wasn’t being used consistently throughout so fixed that too).

    'Automatic generation of appoinment objects in calendar immediately before and after an out of office appointment/meeting to cover travel time
    'Thanks to David Lee at https://techniclee.wordpress.com/2010/07/15/travel-time-for-meetings/
    'Modified by Ben Roberts
    
    Dim WithEvents olkCalendar As Outlook.Items
    
    Const SCRIPT_NAME = "Schedule Travel Time"
    Const CATEGORY_NAME = "Travel"
    
    Private Sub Application_Quit()
        Set olkCalendar = Nothing
    End Sub
     
    Private Sub Application_Startup()
        Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
    End Sub
    
    Private Sub Create_Travel(startDate As Date, endDate As Date, originalItem As Object)
        Set olkTravel = Application.CreateItem(olAppointmentItem)
        With olkTravel
            strNoun = IIf(originalItem.MeetingStatus = olMeeting, "meeting", "appointment")
            strToFrom = IIf(startDate  0, originalItem.Categories & ", " & CATEGORY_NAME, CATEGORY_NAME)
            .BusyStatus = olOutOfOffice
            .ReminderSet = False
            .Importance = originalItem.Importance
            .Sensitivity = originalItem.Sensitivity
            .Save
        End With
        Set olkTravel = Nothing
    End Sub
    
     
    Private Sub olkCalendar_ItemAdd(ByVal Item As Object)
        Dim olkTravel1 As Outlook.AppointmentItem, _
            olkTravel2 As Outlook.AppointmentItem, _
            intMinutes As Integer, _
            strNoun As String
        If InStr(1, Item.Categories, CATEGORY_NAME) = 0 And Item.BusyStatus = olOutOfOffice Then
            If Item.ReminderSet Then
                intMinutes = Item.ReminderMinutesBeforeStart
            Else
                intMinutes = InputBox("How many minutes travel each way?", SCRIPT_NAME, 15)
            End If
            If intMinutes > 0 Then
                Create_Travel _
                    DateAdd("n", intMinutes * -1, Item.start), _
                    Item.start, _
                    Item
                Create_Travel _
                    Item.End, _
                    DateAdd("n", intMinutes, Item.End), _
                    Item
            End If
        End If
    End Sub
    
  3. Another tip: You can add “.ReminderSet = False” to the creation of the two travel time appointments (before “.Save”). In that way you don’t get reminders for the travel time appointments, only for the actual appointment.

  4. Hi David, Great code. Just what I was looking for. Works flawlessly in Outlook 2010. A tip for others: you can hide the automatically added travel time appointments from view by changing view settings:

    In the “View” ribbon, click “View Settings”
    Click the “Filter…” option
    Choose the “Advanced” tab
    Add a rule on the Field “Frequently-used fields” > “Categories”
    Enter the Condition “doesn’t contain”
    Enter the exact category name under Value
    Hit “Ok” to close the dialogs
    In the “View” ribbon, open “Change View” and choose “Save Current View As a New View…”

    Voila, now you have saved a view that filters meetings from certain categories. If you want to switch between the trimmed down view and the full calendar view you can use the “Change View” button in the “View” ribbon.

  5. Hi David,

    We’re experiencing the same situation as Mike Roberts.We are getting the schedule time pop-up before we are able to view the actual meeting. We copied the same code you sent to Mike, but now we are getting the same pop-up on before and after we accept the meeting. Can you help us get rid of the first pop-up? Thank you so much for help, we appreciate it .

  6. David, not sure where I am going wrong but I am getting a compile error with “invalid outside procedure” warning message..

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52

    Public Sub Travel_time()
    Dim WithEvents olkCalendar As Outlook.Items

    Private Sub Application_Quit()
    Set olkCalendar = Nothing
    End Sub

    Private Sub Application_Startup()
    Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
    End Sub

    Private Sub olkCalendar_ItemAdd(ByVal Item As Object)
    Const SCRIPT_NAME = “Schedule Travel Time”
    ‘On the next line change the category name as desired. The code will ignore any meeting or appointment assigned to this category.
    Const CATEGORY_NAME = “Travel”
    Dim olkTravel1 As Outlook.AppointmentItem, _
    olkTravel2 As Outlook.AppointmentItem, _
    intMinutes As Integer, _
    strNoun As String
    If InStr(1, Item.Categories, CATEGORY_NAME) = 0 Then
    strNoun = IIf(Item.MeetingStatus = olMeeting, “meeting”, “appointment”)
    If MsgBox(“Do you need to schedule travel time for this ” & strNoun & “?”, vbQuestion + vbYesNo, SCRIPT_NAME) = vbYes Then
    intMinutes = InputBox(“How many minutes each way?”, SCRIPT_NAME, 15)
    If intMinutes > 0 Then
    Set olkTravel1 = Application.CreateItem(olAppointmentItem)
    With olkTravel1
    .Subject = “Travel to ” & StrConv(strNoun, vbProperCase) & “: ” & Item.Subject
    .Start = DateAdd(“n”, intMinutes * -1, Item.Start)
    .End = Item.Start
    .Categories = IIf(Len(Item.Categories) > 0, Item.Categories & “, Travel”, “Travel”)
    .BusyStatus = olBusy
    .Save
    End With
    Set olkTravel2 = Application.CreateItem(olAppointmentItem)
    With olkTravel2
    .Subject = “Travel from ” & StrConv(strNoun, vbProperCase) & “: ” & Item.Subject
    .Start = Item.End
    .End = DateAdd(“n”, intMinutes, Item.End)
    .Categories = IIf(Len(Item.Categories) > 0, Item.Categories & “, Travel”, “Travel”)
    .BusyStatus = olBusy
    .Save
    End With
    End If
    End If
    End If
    Set olkTravel1 = Nothing
    Set olkTravel2 = Nothing
    End Sub

    • Hi, Dave.

      It looks like you got the line numbers when you copied the code. There shouldn’t be any line numbers.

    • Yep that was the problem, thanks this works great! If I wanted to follow Mike’s logic and have an option to add travel time to a currently open meeting or appointment would I need to add second macro and build a button for the QAT (quick action toolbar) or the ribbon so it could be run this with a single click?

    • You’re welcome, Dave.

      If you want to add travel time manually instead of automatically, then you don’t need a second macro, you’ll just use the macro I posted for Mike. Adding a button to the QAT/ribbon is optional. It certainly makes it easier to run the macro, but you could skip the button and run the macro by clicking Developer -> Macros -> AddTravelTime (in Outlook 2013). Are you familiar with how to add a button to the QAT or the ribbon? If not, what version of Outlook are you using?

  7. This script is great, David! One follow-up question:

    Is there a way to set it up such that the Travel Time message only displays AFTER I’ve ACCEPTED a meeting? I’ve found that the script is a bit preemptive when someone sends me an invitation to a meeting which I haven’t yet accepted… Their invitation appears on my calendar (though greyed out and not-yet-accepted) which prompts the script to run and ask me whether I want to add travel time prior to being able to open/accept the meeting notice.

    Thanks!

    • Hi, Mike.

      Thanks!

      Yes, that’s possible, it just isn’t quite as easy as one might think. Right now, the code is triggered by adding an item to the calendar. The problem with limiting the code to just accepted appointments is finding an event to key on. The logical choice is the event that fires when an item changes. Without getting into how events work in Outlook, the problem is knowing which item the change applies to. The solution is to write two somewhat complicated processes to keep track of which items are open and which item is selected in order to have the code process the correct item. That’s if you want the process of creating the travel appointments to be automatic. If you’re okay with a manual process (e.g. selecting an appointment and clicking a button to add that travel appointments, then that’s easily done.

    • So what tweaks to your existing script would it take to be able to click a button (i.e., manually run the macro) after highlighting/opening an existing meeting in order to add travel time before/after that meeting?

    • Mike,

      I think this will do it. Once you’ve added this code to Outlook, select an appointment and run the macro. It will add travel time for the currently selected/open appointment. You can also add a button to the QAT (quick action toolbar) or the ribbon so you can run this with a single click.

      Sub AddTravelTime()
          'On the next line change the category name as desired.  The code will ignore any meeting or appointment assigned to this category.
          Const CATEGORY_NAME = "Travel"
          Const SCRIPT_NAME = "Add Travel Time"
          Dim olkItem As Object, _
              olkTravel1 As Outlook.AppointmentItem, _
              olkTravel2 As Outlook.AppointmentItem, _
              intMinutes As Integer, _
              strNoun As String
          Select Case TypeName(Application.ActiveWindow)
              Case "Explorer"
                  Set olkItem = Application.ActiveExplorer.Selection(1)
              Case "Inspector"
                  Set olkItem = Application.ActiveInspector.CurrentItem
              Case Else
                  Set olkItem = Nothing
          End Select
          If TypeName(olkItem) = "Nothing" Then
              MsgBox "You must select an appointnment before running this macro.", vbCritical + vbOKOnly, SCRIPT_NAME
          Else
              If olkItem.Class = olAppointment Then
                  If InStr(1, olkItem.Categories, CATEGORY_NAME) = 0 Then
                      intMinutes = InputBox("How many minutes each way?", SCRIPT_NAME, 15)
                      If intMinutes > 0 Then
                          Set olkTravel1 = Application.CreateItem(olAppointmentItem)
                          With olkTravel1
                              .Subject = "Travel to " & StrConv(strNoun, vbProperCase) & ": " & olkItem.Subject
                              .Start = DateAdd("n", intMinutes * -1, olkItem.Start)
                              .End = olkItem.Start
                              .Categories = IIf(Len(olkItem.Categories) > 0, olkItem.Categories & ", Travel", "Travel")
                              .BusyStatus = olBusy
                              .Save
                          End With
                          Set olkTravel2 = Application.CreateItem(olAppointmentItem)
                          With olkTravel2
                              .Subject = "Travel from " & StrConv(strNoun, vbProperCase) & ": " & olkItem.Subject
                              .Start = olkItem.End
                              .End = DateAdd("n", intMinutes, olkItem.End)
                              .Categories = IIf(Len(olkItem.Categories) > 0, olkItem.Categories & ", Travel", "Travel")
                              .BusyStatus = olBusy
                              .Save
                          End With
                      End If
                  End If
              Else
                  MsgBox "This macro only works with appointments.", vbCritical + vbOKOnly, SCRIPT_NAME
              End If
          End If
          Set olkItem = Nothing
          Set olkTravel1 = Nothing
          Set olkTravel2 = Nothing
      End Sub
      
  8. HI David, I love it thank!

    I have 2 questions and I am not a programmer but I still got this to work on Outlook 2013 when my purchased add-in stopped working on this new version.

    1) Is it possible to ask for different travel times in front and after an appointment? Sometimes I go from one to the next and travel times will be different?

    2) Is it possible to have this routine look for changes in meetings too? Sometimes I change the time and/or date or even delete the meeting and the trqavel times don’t get changed. Am I asking for too much?

    Thanks

    • Hi, Scott.

      Thanks!

      1. Yes, that’s possible. Do you want to be prompted for each travel time or do you want to hard code different amounts of time?
      2. That’s possible, but it’s not simple. The only way to detect a change is to write a routine that monitors every item you open in Outlook looking for an appointment. If it sees you open an appointment, then it can check to see if the appointment changed. In this case it’d need to check the appointment’s start and end times and adjust the travel time accordingly. While it’s easy to detect an appointment being deleted, it’s difficult to detect which appointment was deleted. It really boils down to writing a fair amount of code to make this work. It’s doable, just time consuming. I’ll give it some thought.

    • Hi David

      Really like this code, thanks for this. Have just run it on Outlook 2013 perfectly. From your correspondence above with Scott, is is possible to have the request for travel to and travel from?

      Thanks

    • Hi, Tom.

      You’re welcome. Glad you like it. Here’s the modification you requested. This version will prompt for both travel time to and from the appointment.

      Dim WithEvents olkCalendar As Outlook.Items
       
      Private Sub Application_Quit()
          Set olkCalendar = Nothing
      End Sub
       
      Private Sub Application_Startup()
          Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
      End Sub
       
      Private Sub olkCalendar_ItemAdd(ByVal Item As Object)
          Const SCRIPT_NAME = "Schedule Travel Time"
          Dim olkTravel1 As Outlook.AppointmentItem, _
              olkTravel2 As Outlook.AppointmentItem, _
              intTo As Integer, _
              intFrom As Integer
          If Item.MeetingStatus = olMeeting Then
              If MsgBox("Do you need to schedule travel time for this meeting?", vbQuestion + vbYesNo, SCRIPT_NAME) = vbYes Then
                  intTo = InputBox("How many minutes travel time to the appointment?", SCRIPT_NAME, 15)
                  intFrom = InputBox("How many minutes travel time on the return trip?", SCRIPT_NAME, 15)
                  If intTo > 0 Then
                      Set olkTravel1 = Application.CreateItem(olAppointmentItem)
                      With olkTravel1
                          .Subject = "Travel to Meeting: " & Item.Subject
                          .Start = DateAdd("n", intTo * -1, Item.Start)
                          .End = Item.Start
                          .Categories = Item.Categories
                          .BusyStatus = olBusy
                          .Save
                      End With
                  End If
                  If intFrom > 0 Then
                      Set olkTravel2 = Application.CreateItem(olAppointmentItem)
                      With olkTravel2
                          .Subject = "Travel from Meeting: " & Item.Subject
                          .Start = Item.End
                          .End = DateAdd("n", intFrom, Item.End)
                          .Categories = Item.Categories
                          .BusyStatus = olBusy
                          .Save
                      End With
                  End If
              End If
          End If
          Set olkTravel1 = Nothing
          Set olkTravel2 = Nothing
      End Sub
      
    • Sorry, David, I neglected to consider that I had been using the revised code for appointments in addition to meetings. What would I need to amend to revise the excellent code you have provided above? Apologies and thanks again

    • Hi, Tom.

      No worries. This should do it.

      Dim WithEvents olkCalendar As Outlook.Items
       
      Private Sub Application_Quit()
          Set olkCalendar = Nothing
      End Sub
       
      Private Sub Application_Startup()
          Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
      End Sub
       
      Private Sub olkCalendar_ItemAdd(ByVal Item As Object)
          Const SCRIPT_NAME = "Schedule Travel Time"
          'On the next line change the category name as desired.  The code will ignore any meeting or appointment assigned to this category.
          Const CATEGORY_NAME = "Travel"
          Dim olkTravel1 As Outlook.AppointmentItem, _
              olkTravel2 As Outlook.AppointmentItem, _
              intTo As Integer, _
              intFrom As Integer, _
              strNoun As String
          If InStr(1, Item.Categories, CATEGORY_NAME) = 0 Then
              strNoun = IIf(Item.MeetingStatus = olMeeting, "meeting", "appointment")
              If MsgBox("Do you need to schedule travel time for this " & strNoun & "?", vbQuestion + vbYesNo, SCRIPT_NAME) = vbYes Then
                  intTo = InputBox("How many minutes travel time to the appointment?", SCRIPT_NAME, 15)
                  intFrom = InputBox("How many minutes travel time on the return trip?", SCRIPT_NAME, 15)
                  If intTo > 0 Then
                      Set olkTravel1 = Application.CreateItem(olAppointmentItem)
                      With olkTravel1
                          .Subject = "Travel to " & StrConv(strNoun, vbProperCase) & ": " & Item.Subject
                          .Start = DateAdd("n", intTo * -1, Item.Start)
                          .End = Item.Start
                          .Categories = IIf(Len(Item.Categories) > 0, Item.Categories & ", Travel", "Travel")
                          .BusyStatus = olBusy
                          .Save
                      End With
                  End If
                  If intFrom > 0 Then
                      Set olkTravel2 = Application.CreateItem(olAppointmentItem)
                      With olkTravel2
                          .Subject = "Travel from " & StrConv(strNoun, vbProperCase) & ": " & Item.Subject
                          .Start = Item.End
                          .End = DateAdd("n", intFrom, Item.End)
                          .Categories = IIf(Len(Item.Categories) > 0, Item.Categories & ", Travel", "Travel")
                          .BusyStatus = olBusy
                          .Save
                      End With
                  End If
              End If
          End If
          Set olkTravel1 = Nothing
          Set olkTravel2 = Nothing
      End Sub
      
    • Hi David, Thanks for posting these, they work great. I use both methods depending on the situation. I did find a typo in line 22 of the macro above:

      If InStr(1, olkolkItem.Categories, CATEGORY_ …

      olkolkItem – once I removed one of the ‘olk’s I was able to add the button

      Thanks again,

      Mark

    • Hi, Mark.

      I’m glad you like the solution. Thanks for pointing out the typo. I’ve corrected it for future readers.

  9. Hi,

    I love this script. Could you possibly send me the version where this works all types of appointments, not just ones which are meetings. I did try the version where i deleted line 16, and it created an Infinate loop. I read the comments above and saw someone else had the same problem, but i couldn’t understand the answer.

    Thanks for your help in advance. Keep up the Good work!!

    • Hi, Kyle.

      I’m glad you like the script.

      I just added a revision, rev 1, to the post that should allow you to block travel time for appointments as well as meetings. I say “should” because I haven’t had a chance to test the code. Please give it a try and let me know if that’s what you were looking for.

  10. Hi,

    I tried your script in OL 2010 but i doesn’t work. “Warnings for all macros” is defined and acknowledged with yes. Is there any difference when I use Outlook in another language? I use my standard exchange calendar folder.

    BR LR

    • Hi, Lukas.

      No, there shouldn’t be any difference based on language. Did you add the item to your primary calendar and was it a meeting or an appointment? The code only works for the primary calendar and only if the item added is a meeting.

    • Hi David,

      I have no idea why it works now, I tested it yesterday with a meeting and an appointment. I rebooted the machine,…

      But it works now, and your script is really awesome!!!THX!

  11. David, great script. There’s only one problem, it keeps looping with the question “do you want to add traveltime?” until i say no.
    How can i prevent this?

    My code:

    Dim WithEvents olkCalendar As Outlook.Items
    
    Private Sub Application_Startup()
        Set olkCalendar = Session.GetDefaultFolder(olFolderCalendar).Items
    End Sub
    Private Sub Application_Quit()
        Set olkCalendar = Nothing
    End Sub
    
    Private Sub olkCalendar_ItemAdd(ByVal Item As Object)
        Const SCRIPT_NAME = "NET Reistijdplanner"
        Dim olkTravel1 As Outlook.AppointmentItem, _
            olkTravel2 As Outlook.AppointmentItem, _
            intMinutes As Integer
    
            If MsgBox("Wilt u reistijd plannen bij de afspraak?", vbQuestion + vbYesNo, SCRIPT_NAME) = vbYes Then
                intMinutes = InputBox("Hoeveel minuten voor een enkele reis?", SCRIPT_NAME, 60)
                If intMinutes > 0 Then
                    Set olkTravel1 = Application.CreateItem(olAppointmentItem)
                    With olkTravel1
                        'Edit the subject as desired'
                        .Subject = "Reistijd naar: " & Item.Location
                        .Start = DateAdd("n", intMinutes * -1, Item.Start)
                        .End = Item.Start
                        .Categories = "CSN_Reistijd"
                        .BusyStatus = olBusy
                        .Save
                    End With
                    Set olkTravel2 = Application.CreateItem(olAppointmentItem)
                    With olkTravel2
                        'Edit the subject as desired'
                        .Subject = "Reistijd van: " & Item.Location
                        .Start = Item.End
                        .End = DateAdd("n", intMinutes, Item.End)
                        .Categories = "CSN_Reistijd"
                        .BusyStatus = olBusy
                        .Save
                    End With
                End If
            End If
    
        Set olkTravel1 = Nothing
        Set olkTravel2 = Nothing
    End Sub
    
    • Hi, George.

      Thanks, I’m glad you like the script.

      The script is looping because you’ve removed line 16 of the original code. That’s the line that tests to see if the item being added is a meeting or an appointment. Removing it is causing an infinite loop because of course the travel to and travel from entries are appointments. As each of those are added the script is being triggered again to add travel to and from appointments for them. If you want to add travel time for appointments as well as meetings, then you need to restore line 16, but instead of keying on the item being a meeting key on something else. For example, you’re setting a category of “CSN_Reistjid” for the travel to and from appointments. Key on that.

  12. I tried this as well on Outlook 2010, but it didn’t work for me either. I had macros enabled as directed and followed the directions to the letter 3 times. Is there a step missing? One thing I noticed is that no macros are listed under the Developer > Macros tab when I look for something to run. What could the issue be? Could you post a video tutorial?

    • Hi, Sean.

      You won’t see anything in the Developer > Macros tab because it only lists macros that can be run manually. This one runs automatically. It’s triggered by the creation of a meeting on the default calendar. There aren’t any steps missing. I’ll see about putting a video tutorial together. Possible causes of it not working are

      • Creating an appointment instead of a meeting
      • Creating the meeting in a calendar other than the default calendar

      Which macro security setting did you choose?

    • Sean,
      I had an error message pop up that said “compile error: only valid in object module” in Outlook 2010. After researching this error message, I realized that I pasted the code into two places, under “modules” and “ThisOutlookSession”. I deleted the code under “modules” and saved it. After restarting Outlook, the code worked like a charm. I’m really new to creating macros. Thanks David for posting this, having been trying to find a solution to this issue for two weeks!

  13. Hi David

    Yes. I have enabled macros, so that I’m asked at startup – and confirming.
    But nothing happens, when I create a new appointment and save it

    • Hi, Alex.

      I wrote this macro on a computer with Outlook 2007, so I know it works with that version. Did you follow all the instructions I posted? If so, when you start Outlook are you prompted to enable macros?

  14. Hi.

    I tried it in Outlook 2010, but it doesn’t trigger when I create a new appointment.
    Should the code be different, when using Outlook2010?

    Kind regards

    • Hi, Peder.

      The script should work in 2010 without any modification. My first guess is that macros aren’t enabled. Do you know how to check that?

  15. This is an awesome script! I used it as a template for a similar script that I want to execute on every appointment and it works perfectly.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s