Extracting appointments from shared Outlook calendar to Excel

Question

I am trying to extract appointments from a shared Outlook calendar to Excel using a VBA macro in Excel. The code fails whether I try to define objOwner and

Answer 1

Welcome to StackOverflow!

The cause of your issue was using an object for olFolderCalendar, however in context for what you are trying to do you want an Enumeration value of olFolderCalendar which has a value of 9.

I've tidied up the code, and made a few optimization to make this code faster, and added a basic error handler. Great first post :)

Option Explicit

Public Sub ListAppointments()
On Error GoTo ErrHand:

    Application.ScreenUpdating = False

    'This is an enumeration value in context of getDefaultSharedFolder
    Const olFolderCalendar As Byte = 9

    Dim olApp       As Object: Set olApp = CreateObject("Outlook.Application")
    Dim olNS        As Object: Set olNS = olApp.GetNamespace("MAPI")
    Dim olFolder    As Object
    Dim olApt       As Object
    Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("emailAddressHERE")
    Dim NextRow     As Long
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")

    objOwner.Resolve

    If objOwner.Resolved Then 
        Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
    end if

    ws.Range("A1:D1").Value2 = Array("Subject", "Start", "End", "Location")

    'Ensure there at least 1 item to continue
    If olFolder.Items.Count = 0 Then Exit Sub

    'Create an array large enough to hold all records
    Dim myArr() As Variant: ReDim myArr(0 To 3, 0 To olFolder.Items.Count - 1)

    'Add the records to an array
    'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
    On Error Resume Next
    For Each olApt In olFolder.Items
        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        NextRow = NextRow + 1
    Next
    On Error GoTo 0

    'Write all records to a worksheet from an array, this is much faster
    ws.Range("A2:D" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)

    'AutoFit
    ws.Columns.AutoFit

cleanExit:
    Application.ScreenUpdating = True
    Exit Sub

ErrHand:
    'Add error handler
    Resume cleanExit
End Sub