Articles in the "Outlook Travel Time Appointments" series
- Add travel time appointments in Outlook
- 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:
This saves a little real estate in the ribbon because now you only need one button:
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