Add travel time appointments in Outlook

Articles in the "Outlook Travel Time Appointments" series

Add travel time appointments in Outlook [This article]
New form for creating 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 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 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

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

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

On Error GoTo 0

Set objSession = Nothing

End Function

| Next in series

2 thoughts on “Add travel time appointments in Outlook”

Lorrie on November 20, 2017 at 6:16 AM said:

Hi Scott,
Thanks for posting this! I have Outlook for Mac 15.34 and it doesn’t appear to have access to a VBA editor in this updated version. I can’t seem to find a workable macro to create travel time anywhere. Do you know how of a solution either using MS Excel VBA editor to ‘talk’ to Outlook, or via Automator or Applescript (or some other route my digging hasn’t found?)

Million-million thanks in advance!
Scott on November 20, 2017 at 3:25 PM said:

Outlook for Mac 2016 has given up on VBA and it will not be returning. Only Word, PowerPoint, and Excel are getting the VBA Editor. I don’t do much with Mac to know if there is an alternative method, such as a modern add-in to provide that functionality. I can see an add-in being a workable solution. Perhaps I will explore that option for my own edification. If I do and it actually works, I will let you know.