Add travel appointments before and after recurring appointments as recurring appointments.
This code sample was written by Rory.
I figured out how to create recurring appointments that match the recurrence pattern of my master appointment.
Sub AddTravelToMeeting() Dim olItem As AppointmentItem, olItems As Outlook.Items Dim strTravelOut As String Dim strTravelBack As String Dim iTravelMinutesOut As Integer Dim iTravelMinutesBack As Integer Dim xReminder As Variant, yReminder As String, iReminder As Integer Dim oFrm As New frmTravelTime iTravelMinutesOut = 30 'set to initial preferred value in minutes iTravelMinutesBack = 30 'set to initial preferred value in minutes Set olItem = GetCurrentItem() If olItem Is Nothing Then MsgBox "You must select an appointment" Exit Sub ElseIf olItem.Class <> olAppointment Then MsgBox "You must select an appointment" Exit Sub End If With oFrm .Caption = "Add appointment travel times" If Val(Application.Version) > 14 Then .Height = 179 .Width = 247 Else .Height = 172 .Width = 240 End If .TextTimeOut.Value = iTravelMinutesOut .TextTimeBack.Value = iTravelMinutesBack RemoveCloseButton oFrm .Show If .Tag = 0 Then GoTo lbl_Exit strTravelOut = .TextTimeOut.Value strTravelBack = .TextTimeBack.Value iTravelMinutesOut = Val(strTravelOut) iTravelMinutesBack = Val(strTravelBack) If olItem.Location = "" Then olItem.Location = InputBox("Enter location") End If If iTravelMinutesOut <> 0 Then yReminder = InputBox("Enter Remind Before Start to Travel in H:M Format (default 15 min)") If InStr(yReminder, ":") > 0 Then xReminder = Split(yReminder, ":") If xReminder(1) = "" Then iReminder = xReminder(0) * 60 Else iReminder = xReminder(0) * 60 + xReminder(1) End If ElseIf yReminder = "" Then iReminder = 15 Else iReminder = yReminder * 1 End If End If If olItem.RecurrenceState > 1 Then With olItem.Parent .BusyStatus = olOutOfOffice .Categories = "Out of Office" .ReminderSet = False .Save End With Else With olItem .BusyStatus = olOutOfOffice .Categories = "Out of Office" .ReminderSet = False .Save End With End If If iTravelMinutesOut <> 0 Then Call Travel_Add(olItem, "Travel to " & olItem.Location, iTravelMinutesOut, iReminder, DateAdd("n", -iTravelMinutesOut, olItem.Start), True) End If If iTravelMinutesBack > 0 Then Call Travel_Add(olItem, "Return from " & olItem.Location, iTravelMinutesBack, iReminder, olItem.End, False) End If End With Unload oFrm lbl_Exit: Set olItem = Nothing Set olItems = Nothing Set oFrm = Nothing Exit Sub End Sub Private Sub Travel_Add(olItem As AppointmentItem, strSubject As String, iTravelMinutes As Integer, _ iReminder As Integer, dteStart As Date, bRemind As Boolean) Dim cAppt As Outlook.AppointmentItem Dim oPatt As RecurrencePattern Dim cPatt As RecurrencePattern Dim colEx As Exceptions Dim objApptEx As Outlook.AppointmentItem Dim oddAppt As Outlook.AppointmentItem Dim i As Integer Dim newDate As Date Set cAppt = CreateItem(olAppointmentItem) With cAppt '.MeetingStatus = olNonMeeting .Subject = "Travel" .Start = dteStart .Duration = iTravelMinutes .BusyStatus = olOutOfOffice .Categories = "Travel" .ReminderSet = bRemind .ReminderMinutesBeforeStart = iReminder .Sensitivity = olItem.Sensitivity .Save End With If olItem.IsRecurring Then Set cPatt = cAppt.GetRecurrencePattern cPatt = olItem.GetRecurrencePattern Set oPatt = olItem.GetRecurrencePattern With cPatt .RecurrenceType = oPatt.RecurrenceType .DayOfWeekMask = oPatt.DayOfWeekMask .Occurrences = oPatt.Occurrences .PatternStartDate = oPatt.PatternStartDate .PatternEndDate = oPatt.PatternEndDate .Interval = oPatt.Interval End With cAppt.Save Set colEx = oPatt.Exceptions If colEx.Count > 0 Then For i = colEx.Count To 1 Step -1 Set oddAppt = cAppt.GetRecurrencePattern.GetOccurrence(CDate(DateValue(colEx(i)) & " " & TimeValue(cPatt.StartTime))) If colEx.Item(i).Deleted = False Then Set objApptEx = colEx(i).AppointmentItem newDate = CDate(DateValue(objApptEx.Start) & " " & TimeValue(cPatt.StartTime)) oddAppt.Start = newDate oddAppt.Save Else oddAppt.Delete End If Next End If End If End Sub Public Function GetCurrentItem() As Object Dim objApp As Outlook.Application Set objApp = Application On Error GoTo err: Select Case TypeName(objApp.ActiveWindow) Case "Explorer" Set GetCurrentItem = objApp.ActiveExplorer.selection.Item(1) Case "Inspector" Set GetCurrentItem = objApp.ActiveInspector.currentItem End Select GoTo done err: Set GetCurrentItem = Nothing done: Set objApp = Nothing End Function