Add recurring travel appointments to recurring appointments

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