New form for creating travel time appointments in Outlook

Articles in the "Outlook Travel Time Appointments" series

  1. Add travel time appointments in Outlook
  2. New form for creating travel time appointments in Outlook [This article]

I still use my code to create travel time appointments in Outlook.  I updated it a little while ago, though, to streamline it.  It now uses a VBA form to ask for the travel from and travel to times in one dialog:

The travel time form now lets you create both appointments from one dialog.

This saves a little real estate in the ribbon because now you only need one button:

The custom button runs the macro for launching the form and creating the appointments.

It also saves time because you can have it create both appointments in one go.  If you don’t need the to or from appointment created, leave its field blank.  You can download the two form files below, extract them anywhere, then in the VBA editor you can click File->Import File… and select the .frm file.

  TravelTimeForm.zip (1.6 KiB)

You can copy the updated macros below and paste them into ThisOutlookSession in the VBA editor (and delete the macros from the old version).  The OpenOutlookFolder macro hasn’t changed, but is included for convenience.  The CreateTravelAppointment macro is now called CreateAppointment and the only change is that it sets the appointment’s category to Travel.  The CreateTravelToAppointment and CreateTravelFromAppointment macros are now combined into one called CreateTravelAppointment.  This is the macro you want your ribbon button to execute.

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
Sub CreateAppointment(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
    objCalItem.Categories = "Travel"
    '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()
    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
    Dim TravelTimeTo As Integer, TravelTimeFrom As Integer
    
    '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)
        'Display form to get travel time durations
        TravelTimeForm.Show
        TravelTimeTo = TravelTimeForm.TravelToTextBox.Value
        TravelTimeFrom = TravelTimeForm.TravelFromTextBox.Value
        'Create travel time appointments only if value provided
        If TravelTimeTo >= 0 Then
            dtStartTime = objSelectedAppointment.Start - TimeSerial(0, TravelTimeTo, 0)
            strSubject = "Travel to " & objSelectedAppointment.subject
            Call CreateAppointment(strFolderPath, strSubject, dtStartTime, TravelTimeTo, True)
            'Disable reminder because travel appointment has one
            objSelectedAppointment.ReminderSet = False
            objSelectedAppointment.Save
        End If
        If TravelTimeFrom >= 0 Then
            dtStartTime = objSelectedAppointment.End
            strSubject = "Travel from " & objSelectedAppointment.subject
            Call CreateAppointment(strFolderPath, strSubject, dtStartTime, TravelTimeFrom, False)
        End If
        Unload TravelTimeForm
    End If
    
    Set objSelectAppointment = Nothing
    Set objSelection = Nothing
    Set objExplorer = Nothing
        
End Sub

Leave a Reply

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

*