use Excel to import Outlook appointments

Taul

Well-known Member
Joined
Oct 24, 2004
Messages
752
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
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:
Code:
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
 
Last edited:

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,476
Office Version
  1. 365
Platform
  1. Windows
Solution

Taul

Well-known Member
Joined
Oct 24, 2004
Messages
752
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
48,476
Office Version
  1. 365
Platform
  1. Windows
OK, no problem. Thanks for the explanation.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,478
Messages
5,636,567
Members
416,924
Latest member
cmlacerna

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top