use Excel to import Outlook appointments

[Taul]

Hi all,
It’s a bit of a mix between Excel & Outlook.
I hope someone can assist with this, I have some Excel VBA code to import appointments from Outlook into Excel. Pulling into Excel, rather than pushing from Outlook.
The code comes from a downloadable file called “Calendar.xlsm” from Ken Puls and can be found in another site here:- see post #3
https://www.excelguru.ca/forums/showthread.php?776-Copy-Outlook-Calendar-to-Excel

The code works fantastically for a calendar that is in a sub-folder of my own calendar, i.e . a calendar that I have created from my own email account at work.
I am using the downloaded appointments to populate a monthly report in Excel.

I would like to adapt the code so I can download appointments from an outlook calendar that has been shared with me (from a share invitation)
We (5 people) currently use a shared calendar to log our training appointments; the calendar belongs to one of the five and is shared with the other 4 people. All five of us have full access rights.

Can anyone assist or point me in the right direction to get this code adapted to work with a calendar that is opened from a share invitation.

Many thanks
Paul.

The existing code used is:

Public Sub ExtractAppointments()
    With Worksheets("Calendar")
        Call GetCalData(.Range("dtFrom").Value, .Range("dtTo").Value)
    End With
End Sub




Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)
'Source:  http://www.codeforexcelandoutlook.com/blog/2008/08/extract-calendar-data-from-outlook-into-excel/
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' Make sure to reference the Outlook object library before running the code
' End Date is optional, if you want to pull from only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------


    Dim olApp As Object
    Dim olNS As Object
    Dim objRecipient As Object
    Dim myCalItems As Object
    Dim ItemstoCheck As Object
    Dim ThisAppt As Object
    Dim bDebug As Boolean
    Dim MyItem As Object
    Dim StringToCheck As String
    Dim MyBook As Excel.Workbook
    Dim rngStart As Excel.Range
    Dim strTable As String
    Dim strSharedMailboxName As String
    Dim i As Long
    Dim NextRow As Long
    Dim wsTarget As Worksheet


    Set MyBook = Excel.ThisWorkbook
    
'<------------------------------------------------------------------
    'Set names of worksheets, tables and mailboxes here!
    Set wsTarget = MyBook.Worksheets("Calendar")
    strTable = "tblCalendar"
    strSharedMailboxName = wsTarget.Range("mailbox").Value
'------------------------------------------------------------------>
    
    Set rngStart = wsTarget.Range(strTable).Cells(1, 1)


    'Clear out previous data
    With wsTarget.Range(strTable)
        If .Rows.Count > 1 Then .Rows.Delete
    End With


    ' 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


    If EndDate - StartDate > 28 Then
        ' ask if the requestor wants so much info
        If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
            GoTo ExitProc
        End If
    End If


    ' get or create Outlook object and make sure it exists before continuing
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    If olApp Is Nothing Then
        MsgBox "Cannot start Outlook.", vbExclamation
        GoTo ExitProc
    End If


    Set olNS = olApp.GetNamespace("MAPI")


    ' link to shared calendar
    Set objRecipient = olNS.CreateRecipient(strSharedMailboxName)
    objRecipient.Resolve
    Set myCalItems = olNS.GetSharedDefaultFolder(objRecipient, 9).Items '9=olFolderCalendar


    With myCalItems
        .Sort "[Start]", False
        .IncludeRecurrences = True
    End With


    StringToCheck = "[Start] >= " & Chr(34) & StartDate & " 12:00 AM" & Chr(34) & " AND [End] <= " & _
                    Chr(34) & EndDate & " 11:59 PM" & Chr(34)


    Set ItemstoCheck = myCalItems.Restrict(StringToCheck)


    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


        For Each MyItem In ItemstoCheck
            If MyItem.Class = 26 Then ' 26=olAppointment
                ' MyItem is the appointment or meeting item we want,
                ' set obj reference to it
                Set ThisAppt = MyItem


                With rngStart
                    .Offset(NextRow, 0).Value = ThisAppt.Subject
                    .Offset(NextRow, 1).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
                    .Offset(NextRow, 2).Value = Format(ThisAppt.Start, "HH:MM AM/PM")
                    .Offset(NextRow, 3).Value = Format(ThisAppt.End, "MM/DD/YYYY")
                    .Offset(NextRow, 4).Value = Format(ThisAppt.End, "HH:MM AM/PM")
                    .Offset(NextRow, 5).Value = ThisAppt.Location


                    If ThisAppt.Categories <> "" Then
                        .Offset(NextRow, 6).Value = ThisAppt.Categories
                    Else
                        .Offset(NextRow, 6).Value = "n/a"
                    End If
                    NextRow = wsTarget.Range(strTable).Rows.Count


                End With
            End If
        Next MyItem


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


ExitProc:
    Set myCalItems = Nothing
    Set ItemstoCheck = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set rngStart = Nothing
    Set ThisAppt = Nothing
End Sub

 

[Peter_SSs]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules. Be sure to follow & read the link at the end of the rule too!

Cross posted at: https://www.excelguru.ca/forums/showthread.php?8081-Use-Excel-to-import-Outlook-appointments

If you do cross-post in the future and also provide a link, then there shouldn’t be a problem.

 

[Taul]

Thank you Peter for the reminder. My apologies for the cross post.
I tried to submit a question last night on the excel guru site but when I clicked the submit button my chrome browser said the site was blocked and my screen just showed a chrome error message.
I returned to the main forum page to check if my post had been successful but I couldn’t find it, so I concluded my attempt had failed. So I came here to the Mr Excel site (the one I usually frequent) and submitted the question here.

I do apologise for this, I am aware of the cross posting rules / etiquette and it is not something I would deliberately do.

The excelguru thread is here
https://www.excelguru.ca/forums/showthread.php?8081-Use-Excel-to-import-Outlook-appointments

 

[Peter_SSs]

OK, no problem. Thanks for the explanation.