VBA Outlook 2013 Calendar to Excel

[LegendaryCue]

Good afternoon everyone!

I am an absolute rookie when it comes to VBA specifically, but fairly strong with excel. I had a problem I was trying solve to help me determine what percent of my time I am spending during my weeks on specific categorical meetings via Outlook. Essentially exporting my Outlook appointments, into excel, then using a PivotChart to show the % of the time spent on each category (has I have set up in Outlook).

I found a fairly old post that John_w had helped solve a little while back: Outlook Calendar (VBA)

*Which first of all, thank you John_w for input on that thread! If it wasn't for your effort there I wouldn't be as close to solving this problem as I am! so thank you!*

After using a few different versions some code that was similar I was happy to stumble upon this code that John_w had put together, and found that it worked brilliantly! I made some small subtle changes to make it my own, for example the cell references for the GetCalData, and cut back on number of items for ThisAppt, and added a column to subtract the end and start time to give me a duration.

This is where I need help, it worked for me and a few others, however, in some cases, I came across a Run time error, specifically: '-2147467259 (8000 4005)', and when I look at my spreadsheet in excel following this error, it is always a meeting that was either deleted or declined, and the date of the meeting always shows as 1/1/4501. When I click debug it takes me to "rngStart.Offset(r, 4).Value = ThisAppt.Categories". I have chased this rabbit down many holes in outlook, deleted these deleted appointments, however the macro always seems to find something new. I am using Outlook 2013 for my calendar. I am wondering if there is a way to include in the code, something to ignore any declined or deleted invites (if this is even the problem).

To help reference this is the code I have been using (referred to in the post above):

Option Explicit

Dim bWeStartedOutlook As Boolean


Private Function GetCalData(StartDate As Date, Optional EndDate As Date) As Boolean
    ' Exports calendar information to Excel worksheet
    ' -------------------------------------------------
    ' Notes:
    ' If Outlook is not open, it still works, but much
    ' slower (~8 secs vs. 2 secs w/ Outlook open).
    ' End Date is optional, if you want to pull from
    ' only one day, use: Call GetCalData("7/14/2008")
    ' -------------------------------------------------
    
    Dim ThisAppt As Object ' Outlook.AppointmentItem
    Dim MyItem As Object
    Dim StringToCheck As String
    Dim i As Long
    
    ' if no end date was specified, then the requestor
    ' only wants one day, so set EndDate = StartDate
    ' this will let us return appts from multiple dates,
    ' if the requestor does in fact set an appropriate end date
    If EndDate = "12:00:00 AM" Then
        EndDate = StartDate
    End If
    
    If EndDate < StartDate Then
        MsgBox "Those dates seem switched, please check" & _
        "them and try again.", vbInformation
        GoTo ExitProc
    End If
    
    ' get Outlook
    Dim olApp As Object '  Outlook.Application
    Set olApp = GetOutlookApp
    If olApp Is Nothing Then
        MsgBox "Cannot start Outlook.", vbExclamation
        GoTo ExitProc
    End If
    
    ' get default Calendar
    Dim olNS As Object ' Outlook.Namespace
    Dim myCalItems As Object ' Outlook.Items
    Set olNS = olApp.GetNamespace("MAPI")
    Set myCalItems = olNS.GetDefaultFolder(9).Items ' olFolderCalendar
    
    ' ------------------------------------------------------------------
    ' the following code adapted from:
    ' http://www.outlookcode.com/article.aspx?id=30
    '
    With myCalItems
        .Sort "[Start]", False
        .IncludeRecurrences = True
    End With
    '
    StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & _
        " AND [End] <= " & Quote(EndDate & " 11:59 PM")
    Debug.Print StringToCheck
    '
    Dim ItemstoCheck As Object ' Outlook.Items
    Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
    Debug.Print ItemstoCheck.Count
    ' ------------------------------------------------------------------
    
    With Worksheets("CalExport")
        .Range("3:" & .Range("A65536").End(xlUp).Row).ClearContents
    End With
    
    If ItemstoCheck.Count > 0 Then
        ' we found at least one appt
        ' check if there are actually any items in the collection,
        ' otherwise exit
        If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
        
        Application.StatusBar = "********    HANG TIGHT, PERFORMING QUANTUM MATHEMATICS    ********"
        
        ' set up worksheet
        Dim MyBook As Excel.Workbook
        Dim xlSht As Excel.Worksheet
        Dim rngStart As Excel.Range
        Dim rngHeader As Excel.Range
    
        Set MyBook = ThisWorkbook
        Set xlSht = MyBook.Sheets(1)
        Set rngStart = xlSht.Range("A2")
        Set rngHeader = Range(rngStart, rngStart.Offset(0, 5))
        
        ' with assistance from Jon Peltier http://peltiertech.com/WordPress and
        ' http://support.microsoft.com/kb/306022
        rngHeader.Value = Array("Subject", "Start Date", "Start Time", "Location", "Categories", "Duration")
    
        ' create/fill array with exported info
        'Dim ColCount As Long
        'Dim arrData As Variant
        'ColCount = rngHeader.Columns.Count
        'ReDim arrData(1 To ItemstoCheck.Count, 1 To ColCount)
        
        Dim r As Long
        Dim outRecurrencePattern As Object
        
        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 = ThisAppt.Location
            rngStart.Offset(r, 4).Value = ThisAppt.Categories
            rngStart.Offset(r, 5).Value = Format(ThisAppt.End - ThisAppt.Start, "HH:MM")
        
            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 = ThisAppt.Location
                        rngStart.Offset(r, 4).Value = ThisAppt.Categories
                        rngStart.Offset(r, 5).Value = Format(ThisAppt.End - ThisAppt.Start, "HH:MM")
                   End If
                Loop Until ThisAppt Is Nothing
            
            End If
        
            DoEvents
        Next
                
    Else
        MsgBox "There are no original appointments or meetings during" & _
            "the time you specified. Exiting now.", vbCritical
        GoTo ExitProc
    End If
    
    ' if we got this far, assume success
    GetCalData = True
    
ExitProc:
    If bWeStartedOutlook Then
olApp.Quit
    End If
    Set myCalItems = Nothing
    Set ItemstoCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set rngStart = Nothing
    Set ThisAppt = Nothing
   
End Function

Private Function GetNextOccurrence(ByVal startDateTime As Date, EndDate As Date, outRP As Object) As Object 'Outlook.AppointmentItem

    'Increment startDateTime by 1 day until a valid calendar appointment is found or the date exceeds endDate
    
    Do
        startDateTime = startDateTime + 1
        Set GetNextOccurrence = Nothing
        On Error Resume Next
        Set GetNextOccurrence = outRP.GetOccurrence(startDateTime)
        On Error GoTo 0
    Loop While GetNextOccurrence Is Nothing And Int(startDateTime) <= Int(EndDate)
    If Int(startDateTime) > Int(EndDate) Then Set GetNextOccurrence = Nothing
    
End Function

Private Function Quote(MyText)
    ' from Sue Mosher's excellent book "Microsoft Outlook Programming"
    Quote = Chr(34) & MyText & Chr(34)
End Function

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

Sub DnC()
    Dim success As Boolean
    success = GetCalData(Range("B1"), Range("B1") + 4)
    
    ActiveWorkbook.RefreshAll
    Application.StatusBar = "********    UPDATES ARE COMPLETED :)     ********"
End Sub

 

[LegendaryCue]

Some additional context as well, when I run the macro, it does successfully pull the calendar appointments.

This run time error, always seems to occur after most (if not all) the appointments have already been added to the spreadsheet. So it shows up as the last row.
The last one always shows the subject, writes the date as 1/1/4501, then breaks afterwards once it gets to This.Appt.Categories

 

[LegendaryCue]

Just checking back in to see if anyone has come across this issue or has any ideas on this odd 1/1/4501 issue I seem to be having.