Add travel time appointments in Outlook

I like having travel time appointments in my calendar so that my free/busy accurately reflects that I am unavailable, but also so that I am reminded with enough time that I need to leave. I used to use an add-in from Instyler (no link since the site is no longer active) that allowed me to add travel to and/or from appointments to a selected calendar item, but it doesn’t work with Outlook 2013. So I chose to write a macro several years ago to do it. Like my attachment rename macro, when someone asked about using it in a newsletter, it gave me an opportunity to fix the main limitation in my use case: multiple accounts.

The original code leveraged the Applicaton.CreateItem() method, which creates the item in the default folder of the respective item type (olAppointmentItem, in this case). But I have long had two Exchange accounts in my profile, work and personal. I couldn’t get it to create the appointment item in the selected calendar. So I figured out how to open a particular calendar based on the folder path of the selected calendar.

The macro works against single-occurrence appointments and meetings. (Working with recurrences is messy.) There are actually three subroutines and one function. Two of the subs are for indicating which type of travel appointment to create, to or from. The third sub is for actually creating the appointment item, and the function is for opening the target calendar. I modified the ribbon for appointment items to add a button for creating a “travel to” appointment and a button for creating a “travel from” appointment. Each will prompt for how long the travel time should be, defaulting to 30 minutes. The travel to appointment sets a reminder, but the return travel appointment does not. It also uses the subject of the selected item to construct the subject of the travel time appointment. Paste these four code blocks into the VBA editor and then you can assign your added buttons to the CreateTravelToAppointment and CreateTravelFromAppointment subroutines.

Sub CreateTravelToAppointment()
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objSelectedAppointment As Outlook.AppointmentItem
    Dim strFolderPath As String, intMinutes As Integer, dtStartTime As Date, strSubject As String
    
    'Get currently selected appointment item and the calendar it is in
    Set objExplorer = Outlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    'Get path to current calendar folder (allows for working with non-default and additional calendars)
    strFolderPath = objExplorer.CurrentFolder.folderPath
    
    If objSelection.Count <> 1 Then
        noItem = MsgBox("You must first select an appointment item.", vbCritical, "No item selected")
    Else
        Set objSelectedAppointment = objSelection.Item(1)
        'Get travel time duration to calculate start time
        intMinutes = InputBox("How many minutes for the travel time?", "Enter travel minutes", 30)
        dtStartTime = objSelectedAppointment.Start - TimeSerial(0, intMinutes, 0)
        strSubject = "Travel to " & objSelectedAppointment.subject
        Call CreateTravelAppointment(strFolderPath, strSubject, dtStartTime, intMinutes, True)
    End If
    
    Set objSelectAppointment = Nothing
    Set objSelection = Nothing
    Set objExplorer = Nothing
        
End Sub
Sub CreateTravelFromAppointment()
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objSelectedAppointment As Outlook.AppointmentItem
    Dim strFolderPath As String, intMinutes As Integer, dtStartTime As Date, strSubject As String
    
    'Get currently selected appointment item and the calendar it is in
    Set objExplorer = Outlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    'Get path to current calendar folder (allows for working with non-default and additional calendars)
    strFolderPath = objExplorer.CurrentFolder.folderPath
       
    If objSelection.Count <> 1 Then
        noItem = MsgBox("You must first select an appointment item.", vbCritical, "No item selected")
    Else
        Set objSelectedAppointment = objSelection.Item(1)
        'Get travel time duration to calculate start time
        intMinutes = InputBox("How many minutes for the return travel time?", "Enter travel minutes", 30)
        dtStartTime = objSelectedAppointment.End
        strSubject = "Travel from " & objSelectedAppointment.subject
        Call CreateTravelAppointment(strFolderPath, strSubject, dtStartTime, intMinutes, False)
    End If
        
    Set objSelectAppointment = Nothing
    Set objSelection = Nothing
    Set objExplorer = Nothing
    
End Sub
Sub CreateTravelAppointment(path, subject, starttime, duration, setreminder)
    Dim objCalFolder As Outlook.Folder
    Dim objCalItem As Outlook.AppointmentItem
    
    'Get folder object for given path
    Set objCalFolder = OpenOutlookFolder(path)
    'Create appointment item and set properties
    Set objCalItem = objCalFolder.Items.Add
    objCalItem.subject = subject
    objCalItem.Start = starttime
    objCalItem.duration = duration
    objCalItem.BusyStatus = olOutOfOffice
    'Don't set reminder for return travel time
    If setreminder = False Then
        objCalItem.ReminderSet = False
    End If
    objCalItem.Save
    
    Set objCalItem = Nothing
    Set objCalFolder = Nothing
End Sub
Function OpenOutlookFolder(ByVal strPath As String) As Object
    Dim objSession As NameSpace
    Dim arrFolders As Variant, varFolder As Variant, bolBeyondRoot As Boolean
    
    Set objSession = Outlook.Application.GetNamespace("MAPI")

    On Error Resume Next
    Do While Left(strPath, 1) = "\"
        strPath = Right(strPath, Len(strPath) - 1)
    Loop
    arrFolders = Split(strPath, "\")
    For Each varFolder In arrFolders
        Select Case bolBeyondRoot
            Case False
                Set OpenOutlookFolder = objSession.Folders(varFolder)
                bolBeyondRoot = True
            Case True
                Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
        End Select
        If Err.Number <> 0 Then
            Set OpenOutlookFolder = Nothing
            Exit For
        End If
    Next
    On Error GoTo 0
    
    Set objSession = Nothing
    
End Function

Leave a Reply

Your email address will not be published. Required fields are marked *

*