VBA Excel - Recurring Calendar Meeting - Include Appointment Edits/Exceptions

[brianbartell]

Hoping someone can help with this...

I have code (extremely similar to what is linked below) that will extract all Calendar Meetings INCLUDING all Recurring Meeting Appointments from a Series.... I thought this was running perfectly (for years now!), however found that the code doesn't "see" any Appointments that someone has edited (ie: Series has a start/end times of 9:00A-10:00A, however a single Appointment within Series has been changed to a start/end time of 8:00A-9:00A).

Note: The Function GetNextOccurrence looks for the next Appointment within a Recurring Series by incrementing 1 day at a time, so it will take a StartDate such as "09/16/2024 9:00:00 AM" & after incrementing to next day it's now "09/17/2022 9:00:00 AM". Then using:

Set GetNextOccurrence = outRP.GetOccurrence(startDateTime) 'case sensitive!

it looks for an exact match within the Recurring Series. If it finds a match, there's additional code to extract the required Appointment data.. THE PROBLEM is I'm unsure how to have it find the Appointment that has been edited to start at 8:00AM (ie: "09/17/2022 8:00:00 AM"). I've tried several different work-arounds for the past week, haven't had much success...

IDEALLY the code finds any Appointment instance *that exists on any day* within the Recurring Series, regardless of if the start/end time has been modified...

Any ideas??? Thanks in advance!!!

Outlook Calendar (VBA)

I have the below code that pulls the subject, start / end date, start / end time, location, and category from my outlook calendar. however i am trying to find a way to pull the organizer of the calendar event / meeting. Any idea's? Thank you in advance. Dim bWeStartedOutlook As BooleanPrivate...

www.mrexcel.com

 

[John_w]

You need to loop through the RecurrencePattern.Exceptions collection to read the modified occurrences in a recurring series of appointments:

    Dim i As Long
    For i = 1 To ThisAppt.GetRecurrencePattern.Exceptions.Count
        Debug.Print ThisAppt.GetRecurrencePattern.Exceptions(i).AppointmentItem.Start
    Next

I've renamed the GetNextOccurrence function to GetNextOccurrence2 and changed it read the regular recurrences and modified occurences. Note that the startDateTime argument is now passed by reference because the function modifies its value, rather than being modified by the caller; and it has an extra argument, previousExceptionStart.

Private Function GetNextOccurrence2(startDateTime As Date, previousExceptionStart As Date, endDate As Date, outRP As Outlook.RecurrencePattern) As Outlook.AppointmentItem

    'Increment startDateTime by 1 day until a valid calendar appointment is found in a recurring sequence, including exception appointments, or the endDate is exceeded
        
    Dim i As Long
    
    Do
        startDateTime = startDateTime + 1
        Set GetNextOccurrence2 = Nothing
        On Error Resume Next
        Set GetNextOccurrence2 = outRP.GetOccurrence(startDateTime)
        On Error GoTo 0
        If GetNextOccurrence2 Is Nothing Then
            For i = 1 To outRP.Exceptions.Count
                If Int(outRP.Exceptions(i).AppointmentItem.Start) = Int(startDateTime) And outRP.Exceptions(i).AppointmentItem.Start > previousExceptionStart Then
                    Set GetNextOccurrence2 = outRP.Exceptions(i).AppointmentItem
                    previousExceptionStart = GetNextOccurrence2.Start
                End If
            Next
        End If
    Loop While GetNextOccurrence2 Is Nothing And Int(startDateTime) <= Int(endDate)
    If Int(startDateTime) > Int(endDate) Then Set GetNextOccurrence2 = Nothing
    
End Function

The main routine which calls GetNextOccurrence2 needs changing to:

        r = 0
        For Each ThisAppt In ItemstoCheck
            r = r + 1
            rngStart.Offset(r, 0).Value = ThisAppt.Subject
            rngStart.Offset(r, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
            rngStart.Offset(r, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
            rngStart.Offset(r, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
            rngStart.Offset(r, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
            rngStart.Offset(r, 5).Value = ThisAppt.Location
            rngStart.Offset(r, 6).Value = ThisAppt.Categories
                
            If ThisAppt.IsRecurring Then
                
                Dim startDateTime As Date
                Dim previousExceptionStart As Date
                
                startDateTime = ThisAppt.Start
                previousExceptionStart = 0
                
                'Loop through recurring events for this appointment, including exceptions
                
                Set outRecurrencePattern = ThisAppt.GetRecurrencePattern
                Do
                    Set ThisAppt = GetNextOccurrence2(startDateTime, previousExceptionStart, endDate, outRecurrencePattern)
                    If Not ThisAppt Is Nothing Then
                        r = r + 1
                        rngStart.Offset(r, 0).Value = ThisAppt.Subject
                        rngStart.Offset(r, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
                        rngStart.Offset(r, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
                        rngStart.Offset(r, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
                        rngStart.Offset(r, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
                        rngStart.Offset(r, 5).Value = ThisAppt.Location
                        rngStart.Offset(r, 6).Value = ThisAppt.Categories
                   End If
                Loop Until ThisAppt Is Nothing
            
            End If
        
            DoEvents
        Next

Really though, having discovered the RecurrencePattern.Exceptions collection, I would rewrite the code to use a simpler algorithm and a different data structure to store the appointments. The GetNextOccurrence2 function returns one appointment at a time, in ascending date/time order and has to check whether an exception should be returned instead of a regular occurrence.

The new routine would loop through all the regular recurring appointments and store them in an array/Collection/ArrayList; it would then loop through all the exceptions and store them in the same data structure. Then it would sort the data structure by ascending start date and return the array/Collection/ArrayList of appointments.

 

[brianbartell]

thanks for the reply!!! (and my apologies for not responding sooner, needed to find the time to test out your code/solution).... i couldn't make your function work, just ended up in a loop finding the first item in the recurring meeting over & over (???)...

that said: your code helped me get to an actual solution, where I check if each recurring item has any exceptions, then loop thru those & grab the needed data (something similar to what's below). VERY curious about any method to accomplish all of this faster, however. in my own code i store everything in an array before pasting the data, at least that seems to speed things up a little...

r = 0
For Each ThisAppt In ItemstoCheck
r = r + 1
rngStart.Offset(r, 0).Value = ThisAppt.Subject
rngStart.Offset(r, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
rngStart.Offset(r, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
rngStart.Offset(r, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
rngStart.Offset(r, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
rngStart.Offset(r, 5).Value = ThisAppt.Location
rngStart.Offset(r, 6).Value = ThisAppt.Categories

If ThisAppt.IsRecurring Then

'Loop through recurring events for this appointment

Set outRecurrencePattern = ThisAppt.GetRecurrencePattern
Do
Set ThisAppt = GetNextOccurrence(ThisAppt.Start, EndDate, outRecurrencePattern)
If Not ThisAppt Is Nothing Then
r = r + 1
rngStart.Offset(r, 0).Value = ThisAppt.Subject
rngStart.Offset(r, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
rngStart.Offset(r, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
rngStart.Offset(r, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
rngStart.Offset(r, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
rngStart.Offset(r, 5).Value = ThisAppt.Location
rngStart.Offset(r, 6).Value = ThisAppt.Categories
End If
Loop Until ThisAppt Is Nothing

'NEW CODE START
'Loop through any potential recurring EXCEPTION events for this appointment
myExceptions = ThisAppt.GetRecurrencePattern.Exceptions.Count
If myExceptions = Empty Then GoTo skipExceptions
If myExceptions > 0 Then

For e = 1 To myExceptions

r = r + 1
rngStart.Offset(r, 0).Value =ThisAppt.GetRecurrencePattern.Exceptions(e).AppointmentItem.Subject
rngStart.Offset(r, 1).Value =ThisAppt.GetRecurrencePattern.Exceptions(e).AppointmentItem.Start
rngStart.Offset(r, 3).Value =ThisAppt.GetRecurrencePattern.Exceptions(e).AppointmentItem.End
rngStart.Offset(r, 5).Value =ThisAppt.GetRecurrencePattern.Exceptions(e).AppointmentItem.Location

Next e

End If
End If

skipExceptions:
'NEW CODE END

DoEvents
Next

Else
MsgBox "There are no original appointments or meetings during" & _
"the time you specified. Exiting now.", vbCritical
GoTo ExitProc
End If

 

[John_w]

that said: your code helped me get to an actual solution, where I check if each recurring item has any exceptions, then loop thru those & grab the needed data (something similar to what's below). VERY curious about any method to accomplish all of this faster

I've looked in more depth at recurring appointments and learnt much more about them. The following macro outputs to sheet cells the details of single appointments and recurring appointments, including exceptions and deletions, between a specified start date and end date. Each occurrence in a series of recurring appointments is written to consecutive rows.

With recurring appointments, it's important to understand the IncludeRecurrences Boolean property of the Outlook.Items collection:

.IncludeRecurrences = True means the Items collection contains single appointments and all occurrences of recurring appointments as individual appointments.

.IncludeRecurrences = False means the Items collection contains single appointments and only the first (master) appointment of recurring appointments. In addition, if the collection is restricted (using the Restrict method) to appointments within a start and end date range, then a master appointment is included if any occurrence in the series has a start date on or after the specified start date.

The code for this in the main procedure is:

    Set outCalendarItems = outNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar).Items
       
    'Filter string restricts items to those whose Start time occur between the specified start and end dates.
    'Note: for recurring appointments, only the master appointments (the first in the series) are included in the outCalendarItems collection.
    'A master appointment is included if any occurrence in the series has a start date on or after the specified start date.
    
    dateRangeFilter = "[Start] >= '" & startDate & " 00:00' AND [End] <= '" & endDate & " 23:59'"
    
    With outCalendarItems
        'Must sort items in ascending order because GetRecurringAppointments steps through each recurring appointment series in ascending Start date order
        .Sort "[Start]", Descending:=False
        'Next line must be False.  This ensures that outCalendarItems includes only the first (master) appointment of recurring appointments.
        'Each master appointment is passed to GetRecurringAppointments, which reads all the occurrences in the series
        .IncludeRecurrences = False
        Set outCalendarItems = .Restrict(dateRangeFilter)
    End With

GetAppointments is the main routine which interprets and processes both single appointments and recurring appointments. For the latter, it calculates all the occurrences in the series according to the type of recurrence and recurrence pattern. I've done extensive testing and it should work for all the different variations of each recurrence type.

The appointment details are output to the first worksheet in the active workbook.

Here's all the code. It uses early binding of the Outlook Object Library, so you must set a reference to Outlook n.00 Object Library, via Tools -> References in the VBA editor.

Option Explicit


Public Sub Import_Appointments_Grouped()

    Dim OutApp As Outlook.Application
    Dim outNS As Outlook.Namespace
    Dim outCalendarItems As Outlook.Items
    Dim outAppointment As Outlook.AppointmentItem
    Dim OutlookStarted As Boolean
    Dim dateRangeFilter As String
    Dim destCell As Range
    Dim firstDOW As VbDayOfWeek
    Dim startDate As Date, endDate As Date
    
    startDate = DateValue("22/10/2023")
    endDate = DateValue("31/12/2031")
    
    Set destCell = ActiveWorkbook.Worksheets(1).Range("A2")
    destCell.Worksheet.Range("A1").Clear
    
    'Get Outlook
    
    OutlookStarted = GetOutlookApp(OutApp)
    If OutApp Is Nothing Then
        MsgBox "Cannot start Outlook.", vbExclamation
        Exit Sub
    End If
    
    'Get Outlook Calendar's first day of week setting
    
    firstDOW = Get_FirstDayOfWeek(OutApp)
    
    'Get default Calendar
    
    Set outNS = OutApp.GetNamespace("MAPI")

    Set outCalendarItems = outNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar).Items
       
    'Filter string restricts items to those whose Start time occur between the specified start and end dates.
    'Note: for recurring appointments, only the master appointments (the first in the series) are included in the outCalendarItems collection.
    'A master appointment is included if any occurrence in the series has a start date on or after the specified start date.
    
    dateRangeFilter = "[Start] >= '" & startDate & " 00:00' AND [End] <= '" & endDate & " 23:59'"
    
    With outCalendarItems
        'Must sort items in ascending order because the GetAppointments procedure steps through each recurring appointment series in ascending Start date order
        .Sort "[Start]", Descending:=False
        'Next line must be False.  This ensures that outCalendarItems includes only the first (master) appointment of recurring appointments.
        'Each master appointment is passed to GetAppointments, which reads all the occurrences in the series
        .IncludeRecurrences = False
        Set outCalendarItems = .Restrict(dateRangeFilter)
    End With
    
    For Each outAppointment In outCalendarItems
        Debug.Print outAppointment.Start, outAppointment.Subject
        GetAppointments destCell, outAppointment, firstDOW, startDate, endDate
    Next

    'Format the Start, End, Duration and Original Start columns
    
    With destCell.Worksheet
        .Columns("C:D").NumberFormat = "Ddd dd/mm/yyyy hh:mm"
        .Columns("E").NumberFormat = "hh:mm"
        .Columns("L").NumberFormat = "Ddd dd/mm/yyyy hh:mm"
    End With
    
    If OutlookStarted Then OutApp.Quit
    
End Sub


'Process and output both single appointments and recurring appointments
Private Sub GetAppointments(destCell As Range, outFirstAppt As Outlook.AppointmentItem, firstDOW As VbDayOfWeek, startDate As Date, endDate As Date)

    Dim outAppointment As Outlook.AppointmentItem
    Dim outRP As Outlook.RecurrencePattern
    Dim outException As Outlook.Exception
    Dim apptSubject As String
    Dim apptStart As Date, apptEnd As Date, apptDuration As Long
    Dim apptExceptionStart As Date
    Dim apptFirstStart As Date, apptFirstEnd As Date, apptFirstDuration As Long
    Dim apptAllDayEvent As Boolean
    Dim apptRecurrenceState As Outlook.OlRecurrenceState
    Dim nextApptStart As Date
    Dim weekStartDate As Date
    Dim recurrenceDescription As String
    Dim d As Date
    Dim monthDay1Date As Date
    Dim ExceptionNum As Long
    Dim OccurrenceNum As Long
    Dim r As Long, n As Long, i As Long
    Dim calcNext As Boolean
    Dim deletedException As Boolean
                
    With destCell.Worksheet
        .Activate
        If .Range("A1").Value = "" Then
            .Cells.Clear
            .Range("A1:L1").Value = Array("Subject", "Occurrence", "Start", "End", "Duration", "All Day", "Recurrence State", "Recurrence Type", "Recurrence Pattern", "Exception", "Deleted", "Original Start")
        End If
    End With
    
    r = destCell.Row
    n = 0
                            
    Set outAppointment = outFirstAppt
    Set outRP = outFirstAppt.GetRecurrencePattern
    'Dump_RecurrencePattern outRP
    
    'Save details of the first (master) appointment
    
    apptSubject = outFirstAppt.Subject
    apptFirstStart = outFirstAppt.Start
    apptFirstEnd = outFirstAppt.End
    apptFirstDuration = outFirstAppt.Duration
    apptStart = outFirstAppt.Start
    apptEnd = outFirstAppt.End
    apptAllDayEvent = outFirstAppt.AllDayEvent
    
    If outFirstAppt.IsRecurring Then
        recurrenceDescription = CvtRecurrencePattern(outRP, firstDOW)
    Else
        recurrenceDescription = ""
    End If
    
    With outRP
        
        OccurrenceNum = 0
        ExceptionNum = 0
        
        Do
        
            If outFirstAppt.IsRecurring Then
            
                'Get the recurring appointment, or the next exception, associated with the current apptStart
            
                apptExceptionStart = 0
                deletedException = False
                Set outAppointment = Nothing
                On Error Resume Next
                Set outAppointment = outRP.GetOccurrence(apptStart)
                On Error GoTo 0
        
                'Does the appointment for the current apptStart date-time exist?
                 
                If Not outAppointment Is Nothing Then
                     
                    'Yes, but is it an exception?
                     
                    If outAppointment.RecurrenceState = olApptException Then
                        'Yes, so get the exception's appointment.  The start time is the same as the master appointment and the end time is different
                        ExceptionNum = ExceptionNum + 1
                        Set outAppointment = .Exceptions.Item(ExceptionNum).AppointmentItem
                    End If
                    apptSubject = outAppointment.Subject
                    apptStart = outAppointment.Start
                    apptEnd = outAppointment.End
                    apptDuration = outAppointment.Duration
                    apptAllDayEvent = outAppointment.AllDayEvent
                    apptRecurrenceState = outAppointment.RecurrenceState
                
                Else
                 
                    'No; is it a normal exception or is it deleted appointment?
                    If ExceptionNum < .Exceptions.Count Then
                        ExceptionNum = ExceptionNum + 1
                        If Not .Exceptions(ExceptionNum).Deleted Then
                            'A normal exception.  The start time is different to the master appointment
                            'OriginalDate is the appointment's original date and time
                            Set outAppointment = .Exceptions.Item(ExceptionNum).AppointmentItem
                            apptSubject = outAppointment.Subject
                            'Set apptExceptionStart to indicate that appStart must be replaced by apptExceptionStart to calculate the next apptStart
                            apptExceptionStart = .Exceptions.Item(ExceptionNum).OriginalDate
                            apptStart = outAppointment.Start
                            apptEnd = outAppointment.End
                            apptDuration = outAppointment.Duration
                            apptAllDayEvent = outAppointment.AllDayEvent
                            apptRecurrenceState = outAppointment.RecurrenceState
                        Else
                            'A deleted appointment.
                            'OriginalDate is the appointment's original date, without a time (00:00).  Use this original date with the start and end times of the first appointment
                            apptStart = .Exceptions(ExceptionNum).OriginalDate + TimeValue(apptFirstStart)
                            apptEnd = .Exceptions(ExceptionNum).OriginalDate + TimeValue(apptFirstEnd)
                            'Set apptExceptionStart to indicate that appStart must be replaced by apptExceptionStart to calculate the next apptStart
                            apptExceptionStart = .Exceptions(ExceptionNum).OriginalDate + TimeValue(apptFirstStart)
                            deletedException = True
                            apptDuration = apptFirstDuration
                            apptAllDayEvent = False
                            apptRecurrenceState = Outlook.OlRecurrenceState.olApptException
                        End If
                    End If
                     
                 End If
                
            Else
            
                apptSubject = outAppointment.Subject
                apptStart = outAppointment.Start
                apptEnd = outAppointment.End
                apptDuration = outAppointment.Duration
                apptAllDayEvent = outAppointment.AllDayEvent
                apptRecurrenceState = outAppointment.RecurrenceState
           
            End If
            
            OccurrenceNum = OccurrenceNum + 1
            
            'Is this occurrence within the specified date range?
            
            If Int(apptStart) >= startDate And Int(apptStart) <= endDate Then
            
                'Yes, so output the details in sheet row
            
                Debug.Print r; "Occurrence " & OccurrenceNum & ": " & Format(apptStart, "Ddd dd/mm/yyyy hh:mm") & " to " & Format(apptEnd, "hh:mm")
                
                With destCell.Worksheet
                    .Cells(r, "A").Value = apptSubject
                    If apptRecurrenceState = olApptNotRecurring Then
                        .Cells(r, "B").Value = OccurrenceNum & " of 1"
                    ElseIf outRP.NoEndDate Then
                        .Cells(r, "B").Value = OccurrenceNum & " of -"
                    Else
                        .Cells(r, "B").Value = OccurrenceNum & " of " & outRP.Occurrences
                    End If
                    .Cells(r, "C").Value = apptStart
                    .Cells(r, "D").Value = apptEnd
                    .Cells(r, "E").Value = apptDuration / (24 * 60) 'convert minutes to Date value
                    .Cells(r, "F").Value = apptAllDayEvent
                    .Cells(r, "G").Value = CvtRecurrenceState(apptRecurrenceState)
                    If apptRecurrenceState = Outlook.OlRecurrenceState.olApptNotRecurring Then
                        .Cells(r, "H").Value = ""
                        .Cells(r, "I").Value = ""
                    Else
                        .Cells(r, "H").Value = CvtRecurrenceType(outRP.RecurrenceType)
                        .Cells(r, "I").Value = recurrenceDescription
                    End If
                    If apptRecurrenceState = Outlook.OlRecurrenceState.olApptException Then
                        .Cells(r, "J").Value = ExceptionNum & " of " & outRP.Exceptions.Count
                        .Cells(r, "K").Value = deletedException
                        .Cells(r, "L").Value = outRP.Exceptions(ExceptionNum).OriginalDate
                    End If
                    r = r + 1
                    n = n + 1
                End With
                
            End If
            
            'If apptStart output above was an exception start date-time, replace it with the recurrence series start date-time,
            'so that next appointment can be found
            
            If apptExceptionStart <> 0 Then apptStart = apptExceptionStart
            
            'Calculate the next appointment only if the current apptStart date-time is earlier than the specified endDate or
            'the recurrence pattern's end date, whichever is earlier
           
            If apptRecurrenceState = Outlook.OlRecurrenceState.olApptNotRecurring Then
                calcNext = False
            ElseIf .NoEndDate Then
                calcNext = Int(apptStart) <= endDate
            Else
                calcNext = Int(apptStart) <= Application.WorksheetFunction.Min(.PatternEndDate, endDate)
            End If
            
            If calcNext Then
            
                'Calculate the start date-time of the next recurring appointment, depending on the type of recurrence
            
                Select Case .RecurrenceType
                
                    Case Outlook.OlRecurrenceType.olRecursDaily
                    
                        'Occurs every .Interval days
                        
                        apptStart = apptStart + .Interval
                                    
                    Case Outlook.OlRecurrenceType.olRecursWeekly
                    
                        If .Interval = 0 Then
                        
                            'Occurs every weekday
                            
                            apptStart = apptStart + IIf(Weekday(apptStart) = vbFriday, 3, 1)
                            
                        Else
                        
                            'Occurs every .Interval weeks with .DayOfWeekMask determining the days in the week
                            
                            'Date of nearest first day of week prior to current appointment (or first day of week if current appointment is the same day)
                            
                            weekStartDate = apptStart - Weekday(apptStart, firstDOW) + 1
                            
                            'If current appointment is a Sunday (i.e. end of week) then search in the next weekly period
                            
                            If Weekday(apptStart) = vbSunday Then apptStart = weekStartDate + .Interval * 7 - 1
                            
                            'Check days in the current week, starting from the day after the current appointment to Sunday in the same week
                            
                            nextApptStart = 0
                            d = apptStart + 1
                            While d <= apptStart + 8 - Weekday(apptStart) And nextApptStart = 0
                                If (.DayOfWeekMask And 2 ^ (Weekday(d) - 1)) <> 0 Then nextApptStart = d
                                d = d + 1
                            Wend
                            
                            If nextApptStart = 0 Then
                            
                                'Reached end of current week, so add the .Interval weeks and check days in the next weekly period
                                
                                weekStartDate = weekStartDate + 7 * .Interval
                                d = weekStartDate
                                While d <= weekStartDate + 6 And nextApptStart = 0
                                    If (.DayOfWeekMask And 2 ^ (Weekday(d) - 1)) <> 0 Then nextApptStart = d
                                    d = d + 1
                                Wend
                                
                            End If
                            
                            apptStart = nextApptStart
                            
                       End If
                    
                    Case Outlook.OlRecurrenceType.olRecursMonthly
                    
                        'Occurs on day .DayOfMonth of every .Interval months

                        Select Case .DayOfMonth
                            Case 1 To 28
                                apptStart = DateSerial(Year(apptStart), Month(apptStart) + .Interval, .DayOfMonth) + TimeValue(apptStart)
                            Case 29 To 31
                                'For months with 29 to 31 days, the occurrence falls on the last day of the month.
                                apptStart = DateSerial(Year(apptStart), Month(apptStart) + .Interval + 1, 0) + TimeValue(apptStart)
                        End Select
                        
                    Case Outlook.OlRecurrenceType.olRecursMonthNth
                    
                        'Occurs on the .Instance'th weekday name of apptStart every .Interval months
                        
                        Select Case .Instance
                            Case 1 To 4         '1st to 4th weekday name
                                'Date of 1st day of month .Interval months after apptStart
                                monthDay1Date = DateSerial(Year(apptStart), Month(apptStart) + .Interval, 1)
                                apptStart = monthDay1Date - Weekday(monthDay1Date + 7 - Weekday(apptStart)) + 7 * .Instance + TimeValue(apptStart)
                           Case 5               'Last weekday name
                                'Date of 1st day of month .Interval + 1 months after apptStart
                                monthDay1Date = DateSerial(Year(apptStart), Month(apptStart) + .Interval + 1, 1)
                                apptStart = monthDay1Date - Weekday(monthDay1Date + 7 - Weekday(apptStart)) + TimeValue(apptStart)
                        End Select
                    
                    Case Outlook.OlRecurrenceType.olRecursYearly
                    
                        'Occurs every .Interval/12 years on .DayOfMonth'th day of apptStart
                        'Note: .Interval is a multiple of 12 months to give yearly occurrences
                        
                        If Month(apptStart) = 2 And .DayOfMonth = 29 Then
                            apptStart = DateSerial(Year(apptStart), Month(apptStart) + .Interval + 1, 0) + TimeValue(apptStart)
                        Else
                            apptStart = DateSerial(Year(apptStart), Month(apptStart) + .Interval, .DayOfMonth) + TimeValue(apptStart)
                        End If
                        
                    Case Outlook.OlRecurrenceType.olRecursYearNth
                    
                        'Occurs on the .Instance'th weekday name of apptStart month every .Interval/12 years
                        'Note: .Interval is a multiple of 12 months to give yearly occurrences
                        
                        Select Case .Instance
                            Case 1 To 4         '1st to 4th weekday name
                                'Date of 1st day of month .Interval months after apptStart
                                monthDay1Date = DateSerial(Year(apptStart), Month(apptStart) + .Interval, 1)
                                apptStart = monthDay1Date - Weekday(monthDay1Date + 7 - Weekday(apptStart)) + 7 * .Instance + TimeValue(apptStart)
                           Case 5               'Last weekday name
                                'Date of 1st day of month .Interval + 1 months after apptStart
                                monthDay1Date = DateSerial(Year(apptStart), Month(apptStart) + .Interval + 1, 1)
                                apptStart = monthDay1Date - Weekday(monthDay1Date + 7 - Weekday(apptStart)) + TimeValue(apptStart)
                        End Select
                        
                End Select
            
            End If
        
            'Check whether the calculated apptStart date-time is later than the specified endDate or the recurrence pattern's end date, whichever is earlier.
            'If so, the next recurrence is not calculated and the loop ends
        
            If apptRecurrenceState = olApptNotRecurring Then
                calcNext = False
            ElseIf .NoEndDate Then
                calcNext = Int(apptStart) <= endDate
            Else
                calcNext = Int(apptStart) <= Application.WorksheetFunction.Min(.PatternEndDate, endDate)
            End If
            
        Loop While calcNext
        
    End With

    Set destCell = destCell.Offset(n)
    
End Sub


Private Function Get_FirstDayOfWeek(OutApp As Outlook.Application) As VbDayOfWeek

    Dim WshShell As Object
    Dim registryName As String, registryValue As String
    
    'Read Outlook Calendar's first day of week setting in registry
            
    Set WshShell = CreateObject("WScript.Shell")
    registryName = "HKCU\SOFTWARE\Microsoft\Office\" & Split(OutApp.Version, ".")(0) & ".0\Outlook\Options\Calendar\FirstDOW"
    On Error Resume Next
    registryValue = WshShell.RegRead(registryName)
    On Error GoTo 0
    
    'If the registry name is missing, the first day of week defaults to Monday, otherwise the registry value is 0=Sunday, 1=Monday, etc.,
    'which must be converted to vbSunday, vbMonday, etc. values by adding 1 to the registry value
     
    If registryValue = "" Then
        Get_FirstDayOfWeek = vbMonday
    Else
        Get_FirstDayOfWeek = registryValue + 1
    End If

End Function


Private Function GetOutlookApp(outlookApp As Outlook.Application) As Boolean
    GetOutlookApp = False
    On Error Resume Next
    Set outlookApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set outlookApp = CreateObject("Outlook.Application")
        GetOutlookApp = True
    End If
    On Error GoTo 0
End Function


Private Function CvtRecurrenceState(rs As Outlook.OlRecurrenceState) As String

    Select Case rs
        Case Is = Outlook.OlRecurrenceState.olApptNotRecurring
            CvtRecurrenceState = "Not recurring"
        Case Is = Outlook.OlRecurrenceState.olApptMaster
            CvtRecurrenceState = "Master"
        Case Is = Outlook.OlRecurrenceState.olApptOccurrence
            CvtRecurrenceState = "Occurrence"
        Case Is = Outlook.OlRecurrenceState.olApptException
            CvtRecurrenceState = "Exception"
    End Select
    
End Function


Private Function CvtRecurrenceType(rt As Outlook.OlRecurrenceType) As String

    Select Case rt
        Case Is = Outlook.OlRecurrenceType.olRecursDaily
            CvtRecurrenceType = "Daily"
        Case Is = Outlook.OlRecurrenceType.olRecursMonthly
            CvtRecurrenceType = "Monthly"
        Case Is = Outlook.OlRecurrenceType.olRecursMonthNth
            CvtRecurrenceType = "MonthNth"
        Case Is = Outlook.OlRecurrenceType.olRecursWeekly
            CvtRecurrenceType = "Weekly"
        Case Is = Outlook.OlRecurrenceType.olRecursYearly
            CvtRecurrenceType = "Yearly"
        Case Outlook.OlRecurrenceType.olRecursYearNth
            CvtRecurrenceType = "YearNth"
    End Select

End Function


Private Function CvtDayOfWeekMask(dowMask As Long) As String

    Dim i As Long
    
    CvtDayOfWeekMask = ""
    For i = 1 To 7
        If (dowMask And 2 ^ ((i - 1) Mod 7)) <> 0 Then
            CvtDayOfWeekMask = CvtDayOfWeekMask & WeekdayName((i - 1) Mod 7 + 1, True, vbSunday) & ", "
        End If
    Next
    CvtDayOfWeekMask = Left(CvtDayOfWeekMask, Len(CvtDayOfWeekMask) - 2)

End Function


Private Function CvtRecurrencePattern(outRP As Outlook.RecurrencePattern, firstDOW As VbDayOfWeek) As String

    Dim pat As String
    Dim i As Long, n As Long
    
    'Construct a string describing the specified recurrence pattern
    
    With outRP
    
        Select Case .RecurrenceType
        
            Case Outlook.OlRecurrenceType.olRecursDaily
                'Occurs every .Interval days
                pat = "Every " & IIf(.Interval = 1, "day", .Interval & " days")
                            
            Case Outlook.OlRecurrenceType.olRecursWeekly
                If .Interval = 0 Then
                    'Occurs every weekday
                    pat = "Every weekday"
                Else
                    'Occurs every .Interval weeks with .DayOfWeekMask determining the days in the week
                    pat = "Every " & IIf(.Interval = 1, "week", .Interval & " weeks") & " on "
                    n = 0
                    For i = firstDOW To firstDOW + 6
                        If (.DayOfWeekMask And 2 ^ ((i - 1) Mod 7)) <> 0 Then
                            pat = pat & WeekdayName((i - 1) Mod 7 + 1, True, vbSunday) & ", "
                            n = n + 1
                        End If
                    Next
                    If n = 1 Then
                        pat = Left(pat, Len(pat) - 2)
                    Else
                        pat = Left(pat, Len(pat) - 7) & " and " & Mid(pat, Len(pat) - 4, 3)
                    End If
                End If
            
            Case Outlook.OlRecurrenceType.olRecursMonthly
                'Occurs on day .DayOfMonth of every .Interval months
                pat = "Day " & .DayOfMonth & " of every " & IIf(.Interval = 1, "month", .Interval & " months")
                
            Case Outlook.OlRecurrenceType.olRecursMonthNth
                'Occurs on the .Instance'th weekday name of .PatternStartDate every .Interval months
                'REPLACE .PATTERNSTARTDATE
                pat = Choose(.Instance, "First", "Second", "Third", "Fourth", "Last") & " " & Format(.PatternStartDate, "Ddd") & " of every " & IIf(.Interval = 1, "month", .Interval & " months")
                
            Case Outlook.OlRecurrenceType.olRecursYearly
                'Occurs every .Interval/12 years on .DayOfMonth day of .MonthOfYear
                'Note: .Interval is a multiple of 12 months to give yearly occurrences
                pat = "Every " & IIf(.Interval = 12, "year", .Interval / 12 & " years") & " on " & .DayOfMonth & " " & MonthName(.MonthOfYear, True)
                            
            Case Outlook.OlRecurrenceType.olRecursYearNth
                'Occurs on the .Instance'th weekday name of .MonthOfYear month every .Interval/12 years
                'Note: .Interval is a multiple of 12 months to give yearly occurrences
                pat = "Every " & IIf(.Interval = 12, "year", .Interval / 12 & " years") & " on " & Choose(.Instance, "first", "second", "third", "fourth", "Last") & " " & CvtDayOfWeekMask(.DayOfWeekMask) & " in " & MonthName(.MonthOfYear, True)
        
        End Select
    
        pat = pat & " starting " & Format(.PatternStartDate, "Ddd ") & .PatternStartDate
        If Not .NoEndDate Then
            pat = pat & " until " & Format(.PatternEndDate, "Ddd ") & .PatternEndDate
        End If
        pat = pat & " from " & Format(.StartTime, "hh:mm") & " to " & Format(.EndTime, "hh:mm")
        
    End With
     
    CvtRecurrencePattern = pat
    
End Function


Private Sub Dump_RecurrencePattern(outRP As Outlook.RecurrencePattern)

    With outRP
        Debug.Print "RecurrenceType = " & .RecurrenceType; " "; CvtRecurrenceType(.RecurrenceType)
        Debug.Print "DayOfWeekMask = " & Application.WorksheetFunction.Dec2Bin(.DayOfWeekMask, 7);
        Debug.Print " " & CvtDayOfWeekMask(.DayOfWeekMask)
        Debug.Print "DayOfMonth = " & .DayOfMonth
        Debug.Print "MonthOfYear = " & .MonthOfYear
        Debug.Print "StartTime = " & .StartTime
        Debug.Print "EndTime = " & .EndTime
        Debug.Print "Duration = " & .Duration
        Debug.Print "Exceptions = " & .Exceptions.Count
        Debug.Print "Instance = " & .Instance
        Debug.Print "Interval = " & .Interval
        Debug.Print "NoEndDate = " & .NoEndDate
        Debug.Print "Occurrences = " & .Occurrences
        Debug.Print "PatternStartDate = " & Format(.PatternStartDate, "Ddd dd/mm/yyyy")
        Debug.Print "PatternEndDate = " & Format(.PatternEndDate, "Ddd dd/mm/yyyy")
        Debug.Print
    End With

End Sub