VBA to export recurring meeting data

[lvcourtney]

I'm using this code to try and export data from recurring meetings. I can't get it to populate data for the meeting organizer, participants, and whether they are required or optional. Also, how can I get the frequency to show Biweekly or Bimonthly or Quarterly? Thanks in advance!

Sub TrackRecurringMeetings()
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim Folder As Object
Dim Appointment As Object
Dim RecPattern As Object
Dim ws As Worksheet
Dim i As Integer
Dim Frequency As String
Dim Executives() As Variant
Dim tbl As ListObject
Dim FromDate As Date
Dim ToDate As Date

On Error Resume Next ' Avoid errors

FromDate = CDate(InputBox("Enter start date"))
ToDate = CDate(InputBox("Enter end date"))

' Array of executive email addresses
Executives = Array("joe@abc.com", "sam@abc.com", "billy@abc.com")

' Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")

For i = LBound(Executives) To UBound(Executives)
Dim execName As String
execName = Split(Split(Executives(i), "@")(0), ".")(0)

' Check if the sheet already exists, otherwise add a new one
Dim sheetExists As Boolean
sheetExists = False
For Each ws In ThisWorkbook.Sheets
If ws.Name = execName Then
sheetExists = True
Exit For
End If
Next ws

If Not sheetExists Then
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = execName
Else
Set ws = ThisWorkbook.Sheets(execName)
ws.Cells.Clear
End If

' Headers
Dim headers() As Variant
headers = Array("Meeting Name", "Length", "Frequency", "Day of Week", "Start Time", _
"Location", "Organizer", "Master Created Date", "Meeting Expiration Date", "Required/Optional", _
"Recurrence Pattern", "Next Scheduled Occurrence", "Required Attendees")
For j = 0 To UBound(headers)
ws.Cells(1, j + 1).Value = headers(j)
Next j

' Access the Calendar folder
Set Folder = OutlookNamespace.GetSharedDefaultFolder(OutlookNamespace.CreateRecipient(Executives(i)), 9)

Dim LastRow As Long
For Each Appointment In Folder.Items
If Appointment.IsRecurring And Len(Appointment.Subject) > 0 And Appointment.Duration <= 180 Then
' Check if the appointment falls within the specified date range
If Appointment.Start >= FromDate And Appointment.Start <= ToDate Then
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
ws.Cells(LastRow, 1).Value = Appointment.Subject
ws.Cells(LastRow, 2).Value = Appointment.Duration

Set RecPattern = Appointment.GetRecurrencePattern
Select Case RecPattern.RecurrenceType
Case 0: Frequency = "Daily"
Case 1: Frequency = "Weekly"
Case 2: Frequency = "Monthly"
Case 3: Frequency = "MonthNth"
Case 5: Frequency = "Yearly"
Case 6: Frequency = "YearNth"
Case Else: Frequency = "Unknown"
End Select
ws.Cells(LastRow, 3).Value = Frequency
ws.Cells(LastRow, 4).Value = WeekdayName(Weekday(Appointment.Start, vbSunday))
ws.Cells(LastRow, 5).Value = Format(Appointment.Start, "h:mm AM/PM")

' Additional Information
ws.Cells(LastRow, 6).Value = Appointment.Location
ws.Cells(LastRow, 7).Value = Appointment.Organizer
ws.Cells(LastRow, 8).Value = Format(RecPattern.PatternStartDate, "mm/dd/yyyy")
ws.Cells(LastRow, 9).Value = Format(RecPattern.PatternEndDate, "mm/dd/yyyy")
ws.Cells(LastRow, 10).Value = IIf(Appointment.Recipients.Item(1).Type = olOptional, "Optional", "Required")

' Recurrence Pattern
ws.Cells(LastRow, 11).Value = RecPattern.PatternString
' Next Scheduled Occurrence
ws.Cells(LastRow, 12).Value = GetNextScheduledOccurrence(RecPattern, Appointment.Start)
' Required Attendees
ws.Cells(LastRow, 13).Value = GetAttendees(Appointment.Recipients)
End If
End If
Next Appointment

' Autofit column width for all columns
ws.Cells.EntireColumn.AutoFit

' Convert data to table
Set tbl = ws.ListObjects.Add(xlSrcRange, ws.Range("A1").CurrentRegion, , xlYes)
tbl.Name = execName & "_Table"
tbl.TableStyle = "TableStyleMedium9"

' Apply conditional formatting to Frequency column
Dim freqCol As Range
Set freqCol = tbl.ListColumns("Frequency").DataBodyRange

freqCol.FormatConditions.AddColorScale ColorScaleType:=3
freqCol.FormatConditions(freqCol.FormatConditions.Count).SetFirstPriority
freqCol.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue
freqCol.FormatConditions(1).ColorScaleCriteria(1).FormatColor.Color = RGB(255, 0, 0)
freqCol.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile
freqCol.FormatConditions(1).ColorScaleCriteria(2).Value = 50
freqCol.FormatConditions(1).ColorScaleCriteria(2).FormatColor.Color = RGB(255, 255, 0)
freqCol.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue
freqCol.FormatConditions(1).ColorScaleCriteria(3).FormatColor.Color = RGB(0, 255, 0)
Next i

On Error GoTo 0 ' Disable error handling

MsgBox "Recurring Meetings Extracted Successfully!", vbInformation

End Sub

Function GetNextScheduledOccurrence(RecPattern As Outlook.RecurrencePattern, StartDate As Date) As Date
On Error Resume Next
GetNextScheduledOccurrence = RecPattern.GetOccurrence(StartDate).Start
On Error GoTo 0
End Function

Function GetAttendees(Recipients As Outlook.Recipients) As String
Dim i As Integer
Dim attendees As String
attendees = ""

For i = 1 To Recipients.Count
attendees = attendees & Recipients.Item(i).Name & "; "
Next i

GetAttendees = Left(attendees, Len(attendees) - 2)
End Function

 

[John_w]

I can't get it to populate data for the meeting organizer, participants, and whether they are required or optional.

Use this code inside the For Each Appointment In Folder.Items loop to get the list of required and optional attendees:

    Dim recip As Outlook.Recipient
    Dim requiredAttendees As String, optionalAttendees As String
                requiredAttendees = ""
                optionalAttendees = ""
                For Each recip In Appointment.Recipients
                    If recip.Type = olRequired Then
                        requiredAttendees = requiredAttendees & recip.Name & ", "
                    ElseIf recip.Type = olOptional Then
                        optionalAttendees = optionalAttendees & recip.Name & ", "
                    End If
                Next
                If requiredAttendees <> "" Then Debug.Print Left(requiredAttendees, Len(requiredAttendees) - 2)
                If optionalAttendees <> "" Then Debug.Print Left(optionalAttendees, Len(optionalAttendees) - 2)

Also, how can I get the frequency to show Biweekly or Bimonthly or Quarterly?

Read the RecurrenceType and Interval properties of the RecurrencePattern object, like this:

    Select Case RecPattern.RecurrenceType
        Case Outlook.OlRecurrenceType.olRecursWeekly
            If RecPattern.Interval = 2 Then Debug.Print "Biweekly"
        Case Outlook.OlRecurrenceType.olRecursMonthly
            If RecPattern.Interval = 2 Then
                Debug.Print "Bimonthly"
            ElseIf RecPattern.Interval = 3 Then
                Debug.Print "Quarterly"
            End If
        Case Outlook.OlRecurrenceType.olRecursMonthNth
            If RecPattern.Interval = 2 Then
                Debug.Print "Bimonthly"
            ElseIf RecPattern.Interval = 3 Then
                Debug.Print "Quarterly"
            End If
    End Select

Note: the above code requires a reference to Microsoft Outlook xx.0 Object Library.