Importing outlook calendar into excel

[Prem Kumar]

Below is my code (mostly googled and then tailored to my needs) that helps me import all the calendar appointments in outlook for the next 30 days. It works perfectly well, except for one part - I'm not able to view the shared calendar items.
Can someone please help me with this?

Much thanks in advance.

Code:

Sub Appointments()
Range("a2:e100").Select
Selection.ClearContents
Application.ScreenUpdating = False
    Call GetCalData(DateTime.Date, DateTime.Date + 30)
Application.ScreenUpdating = True
End Sub
 
Private Sub GetCalData(startdate As Date, Optional EndDate As Date)
 
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myCalItems As Outlook.Items
Dim ItemstoCheck As Outlook.Items
Dim ThisAppt As Outlook.AppointmentItem
Dim MyItem As Object
Dim StringToCheck As String
Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range
Dim i As Long
Dim NextRow As Long
 
 
If EndDate < startdate Then
    MsgBox "Those dates seem switched, please check them and try again.", vbInformation
    GoTo ExitProc
End If
 
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")
Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items
 
 
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
'
Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
Debug.Print ItemstoCheck.Count
' ------------------------------------------------------------------
If ItemstoCheck.Count > 0 Then
    If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
        Set MyBook = ThisWorkbook
        Set rngStart = ThisWorkbook.Sheets(1).Range("A1")
        With rngStart
            .Offset(0, 0).Value = "Date"
            .Offset(0, 1).Value = "Subject"
            .Offset(0, 2).Value = "Duration"
            .Offset(0, 3).Value = "Location"
            .Offset(0, 4).Value = "Categories"
        End With
        For Each MyItem In ItemstoCheck
            If MyItem.Class = olAppointment Then
                Set ThisAppt = MyItem
                NextRow = Range("A" & Rows.Count).End(xlUp).Row
                With rngStart
                    .Offset(NextRow, 0).Value = ThisAppt.Start
                    .Offset(NextRow, 1).Value = ThisAppt.Subject
                    .Offset(NextRow, 2).Value = ThisAppt.Duration & " Min"
                    .Offset(NextRow, 3).Value = ThisAppt.Location
                    .Offset(NextRow, 4).Value = ThisAppt.Categories
                End With
            End If
        Next MyItem
        Call Cool_Colors(rngStart)
    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
 
Private Function Quote(MyText)
Quote = Chr(34) & MyText & Chr(34)
End Function
 
Private Sub Cool_Colors(rng As Excel.Range)
With Range("A1:E1")
    .Font.ColorIndex = 2
    .Font.Bold = True
    With .Interior
        .ColorIndex = 23
        .Pattern = xlSolid
    End With
End With
End Sub

EDIT: Please use code TAG..

 

[RmarkR]

bump...... any update on this?

 

[SirJB7]

Hi, RmarkR!
You're posting in a very old thread (more than 3 years and a half!). Please start a new thread and post a link to this old one if you think it might help.
Regards!
PS: Don't reply to this message. Thank you.