Pull Outlook shared calendars items from Excel

Chooriang

Member
Outlook version
Outlook 2010 64 bit
Email Account
Outlook.com (as MS Exchange)
I have the following function in Excel to access shared calendar folders in Outlook and list all certain appointments (identified from its subject) within specified date range. The code seems doesn't work as expected as Outlook is loaded from Citrix server. The function always returns "Calendar not shared".
I'm not so sure about this and need somebody's help on how to solve this.
Code:
Option Explicit
Function GetColleagueAppointments(dtStartAppt As Date, dtEndAppt As Date, strUserName As String) 'As String
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Purpose:      List down all colleague's client meetings between date range
'
' Inputs:       dtStartAppt         Start date to search
'               dtEndAppt           End date to search
'               strUserName         Colleague calendars to search
'
' Assumptions:  * User must have access to the appropriate shared calendars in
'                 Outlook
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Dim objOL As New Outlook.Application    ' Outlook
Dim objNS As NameSpace                  ' Namespace
Dim OLFldr As Outlook.MAPIFolder        ' Calendar folder
Dim OLAppt As Object                    ' Single appointment
Dim OLRecip As Outlook.Recipient        ' Outlook user name
Dim OLAppts As Outlook.Items            ' Appointment collection
Dim oFinalItems As Outlook.Items
Dim strRestriction As String                    ' Day for appointment
Dim strList() As String                 ' List of all available timeslots
Dim dtmNext As Date                     ' Next available time
Dim intDuration As Integer              ' Duration of free timeslot
Dim i As Integer                        ' Counter
Dim lr As Long, r As Long
Dim wb As Workbook
Dim ws As Worksheet

'FastWB True
Set wb = ThisWorkbook
Set ws = wb.Sheets("Meeting List")

Const C_Procedure = "GetColleagueAppointments"    ' Procedure name
'This is an enumeration value in context of getDefaultSharedFolder
Const olFolderCalendar As Byte = 9

strRestriction = "[Start] >= '" & _
                    Format$(dtStartAppt, "mm/dd/yyyy hh:mm AMPM") _
                    & "' AND [End] <= '" & _
                    Format$(dtEndAppt, "mm/dd/yyyy hh:mm AMPM") & "'"

' loop through shared Calendar for all Employees in array
Set objNS = objOL.GetNamespace("MAPI")

With ws
    On Error Resume Next
    Set OLRecip = objNS.CreateRecipient(strUserName)

    OLRecip.Resolve

    'If OLRecip.Resolved Then
        'Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
        Set OLFldr = objNS.GetSharedDefaultFolder(OLRecip, olFolderCalendar)
    'End If

    ' calendar not shared
    If Err.Number <> 0 Then
        '#   Employee    Date    Start   End Client  Agenda  Location
        r = Last(1, .Columns("G")) + 1
        .Range("F" & r).Value = r - 1                           '#
        .Range("G" & r).Value = strUserName                       'Employee
        .Range("H" & r).Value = "Calendar not shared" 'Format(dtStartAppt, "d-mmm-yyyy")   'Date
        .Range("I" & r).Value = "Calendar not shared"           'Start
        .Range("J" & r).Value = "Calendar not shared"           'End
        .Range("K" & r).Value = "Calendar not shared"           'Client
        .Range("L" & r).Value = "Calendar not shared"           'Agenda
        .Range("M" & r).Value = "Calendar not shared"           'Location

        GoTo ExitHere
    End If

    'On Error GoTo ErrHandler
    Set OLAppts = OLFldr.Items

    ' Sort the collection (required by IncludeRecurrences)
    OLAppts.Sort "[Start]"

    ' Make sure recurring appointments are included
    OLAppts.IncludeRecurrences = True

    ' Filter the collection to include only the day's appointments
    Set OLAppts = OLAppts.Restrict(strRestriction)

    'Construct filter for Subject containing 'Client'
    Const PropTag  As String = "http://schemas.microsoft.com/mapi/proptag/"
    strRestriction = "@SQL=" & Chr(34) & PropTag _
                        & "0x0037001E" & Chr(34) & " like '%Client%'"

    ' Filter the collection to include only the day's appointments
    Set OLAppts = OLAppts.Restrict(strRestriction)

    ' Sort it again to put recurring appointments in correct order
    OLAppts.Sort "[Start]"

    With OLAppts
        ' capture subject, start time and duration of each item
        Set OLAppt = .GetFirst

        Do While TypeName(OLAppt) <> "Nothing"
            r = Last(1, .Columns("G")) + 1

            '- Client - HSBC - Trade Reporting
            '#   Employee    Date    Start   End Client  Agenda  Location

            If InStr(LCase(OLAppt.Subject), "client") > 0 Then
                strList = Split(OLAppt.Subject, "-")
                .Range("F" & r).Value = r - 1
                .Range("G" & r).Value = strUserName
                .Range("H" & r).Value = Format(dtStartAppt, "d-mmm-yyyy")
                .Range("I" & r).Value = OLAppt.Start
                .Range("J" & r).Value = OLAppt.End
                .Range("K" & r).Value = Trim(CStr(strList(1)))
                .Range("L" & r).Value = Trim(CStr(strList(2)))
                .Range("J" & r).Value = OLAppt.Location

            End If
            Set OLAppt = .GetNext
        Loop
    End With
End With

ExitHere:
    On Error Resume Next
    Set OLAppt = Nothing
    Set OLAppts = Nothing
    Set objNS = Nothing
    Set objOL = Nothing
    Exit Function

ErrHandler:
    MsgBox Err.Number & ": " & C_Procedure & vbCrLf & Err.Description
    Resume ExitHere
End Function
 
Last edited by a moderator:

Chooriang

Member
Outlook version
Outlook 2010 64 bit
Email Account
Outlook.com (as MS Exchange)
Diane,
Thank you for your response.

I change my approach and place modified version of your code in Outlook.
But I get "run time error: You don't have permission to perform this operation"

It highlights the following line and it fails to return all appointments.
Code:
Set CalFolder = objNavFolder.folder

So, what's wrong with the following complete code?
Code:
'Const intFolder As Integer = 2
'Const strGroup As String = "Shared Calendars"
Const strKeyword As String = "Client"

Dim CalFolder As Outlook.folder
Dim nameFolder
Dim strResults As String
Dim dStart As Date
Dim dEnd As Date

' Run this macro
Sub SEARCH_IN_SHARED_CALENDARS()
     Dim objPane As Outlook.NavigationPane
     Dim objModule As Outlook.CalendarModule
     Dim objGroup As Outlook.NavigationGroup
     Dim objNavFolder As Outlook.NavigationFolder
     Dim objCalendar As folder
     Dim objFolder As Outlook.folder
     Dim fName As String, strDate As String
     Dim varLine As Variant, varItems As Variant, varDate As Variant
    
     Dim i As Integer, r As Integer
     Dim g As Integer, x As Integer
     Dim valid As Boolean: valid = True
    
    'strKeyword
    Do
        strDate = InputBox("Enter a date range with format of" & vbCrLf & """m/d/yyyy-m/d/yyyy""", "Enter Date Range")
        varDate = Split(strDate, "-")
        If strDate = "" Or UBound(varDate) <> 1 Then
            MsgBox "Invalid date range!", vbCritical, "Process Failed"
            Exit Sub
        End If
        
        If IsDate(varDate(0)) And IsDate(varDate(1)) Then
            ' set dates
            dStart = CDate(varDate(0)) 'Date
            dEnd = CDate(varDate(1))
            valid = True
        Else
            MsgBox "Incorrect date range format!", vbExclamation, "Warning"
            valid = False
        End If
    Loop Until valid = True
    
    'On Error Resume Next
    Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
    Set Application.ActiveExplorer.CurrentFolder = objCalendar
    DoEvents
    Set objPane = Application.ActiveExplorer.NavigationPane
    Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
    
    'valid = False
    'With objModule.NavigationGroups
    '    For g = 1 To .Count
    '        Set objGroup = .Item(g)
    '        'fName = fName & objGroup.GroupType & ". " & objGroup.Name = strGroup& vbCrLf
    '        If objGroup.GroupType = intFolder And Trim(objGroup.Name) = strGroup Then
    '            valid = True
    '            x = g
    '            Exit For
    '        End If
    '    Next
    'End With
    
    If valid = False Then
        MsgBox "No shared calendars folder named with ""Shared Calendars""", vbExclamation, "No Shared Calendars"
        Exit Sub
    End If
    'On Error GoTo 0
    
        enviro = CStr(Environ("USERPROFILE"))
        'the path of the workbook
        strPath = enviro & "\Desktop\Meeting List (" & Format(Now(), "ddmmyy hhnn") & ").xlsx"
        
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        End If
        xlApp.Visible = True
        On Error GoTo 0
        
        On Error Resume Next
        ' Open the workbook to input the data
        ' Create workbook if doesn't exist
        Set xlWB = xlApp.Workbooks.Open(strPath)
        If Err <> 0 Then
        Set xlWB = xlApp.Workbooks.Add
        xlWB.SaveAs fileName:=strPath
        End If
        On Error GoTo 0
        Set xlSheet = xlWB.Sheets("Sheet1")
        
        If xlSheet.Range("A1") = "" Then
            xlSheet.Range("A1") = "#"
            xlSheet.Range("B1") = "UserName"
            xlSheet.Range("C1") = "Date"
            xlSheet.Range("D1") = "Start"
            xlSheet.Range("E1") = "End"
            xlSheet.Range("F1") = "Client"
            xlSheet.Range("G1") = "Agenda"
            xlSheet.Range("H1") = "Location"
            xlWB.Save
        End If
    
    Dim NS As Outlook.NameSpace
    Dim objOwner As Outlook.Recipient
    
     With objModule.NavigationGroups
        For g = 1 To .Count
            Set objGroup = .Item(g)
            'fName = objGroup.GroupType & ". " & Trim(objGroup.Name) & vbCrLf & _
                    intFolder & ". " & strGroup & vbCrLf & strKeyword
            'MsgBox fName
            If objGroup.GroupType = 1 Or objGroup.GroupType = 2 Then
                For i = 1 To objGroup.NavigationFolders.Count
                    Set objNavFolder = objGroup.NavigationFolders.Item(i)
                    'If objNavFolder.IsSelected = True Then
                         strResults = ""
                         Set CalFolder = objNavFolder.folder
                         Set nameFolder = objNavFolder
                         Set NS = Application.GetNamespace("MAPI")
                         Set objOwner = NS.CreateRecipient(nameFolder)
                        
                         objOwner.Resolve
                         If objOwner.Resolved Then
                            Set CalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
                         End If
                        
                        SearchSharedCalendar
                        
                        If strResults <> "" Then
                            varLine = Split(strResults, vbCrLf)
                            For r = LBound(varLine) To UBound(varLine) - 1
                                'Find the next empty line of the worksheet
                                rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
                                rCount = rCount + 1
                                
                                varItems = Split(varLine(r), "~~")
                                xlSheet.Range("A" & rCount) = rCount - 1
                                xlSheet.Range("B" & rCount & ":" & "H" & rCount) = varItems
                                xlWB.Save
                            Next r
                        End If
                    'End If
                Next i
            End If
        Next g
     End With
    
     Set objPane = Nothing
     Set objModule = Nothing
     Set objGroup = Nothing
     Set objNavFolder = Nothing
     Set objCalendar = Nothing
     Set objFolder = Nothing
End Sub

Private Sub SearchSharedCalendar()
     Dim CalItems As Outlook.Items
     Dim ResItems As Outlook.Items
     Dim oFinalItems As Outlook.Items
     Dim sFilter As String
     Dim itm As Object
     Dim strAppt As String
     Dim strList() As String, strData(0 To 6) As String
    
     Set CalItems = CalFolder.Items
    
     ' Sort all of the appointments based on the start time
     CalItems.Sort "[Start]"
    
     ' body key word doesn't work if including recurring
     CalItems.IncludeRecurrences = True
    
     On Error Resume Next
     ' if you arent search subfolders, you only need parent name
     'strName = CalFolder.Parent.Name & " - " & CalFolder.Name
    
     ' filter by date first
     sFilter = "[Start] >= '" & dStart & "'" & " And [Start] < '" & dEnd & "'"
     'Debug.Print sFilter
    
     'Restrict the Items collection within date range
     Set ResItems = CalItems.Restrict(sFilter)
    
     ' Filter for Subject containing strKeyword '0x0037001E (body is 0x1000001f)
     Const PropTag  As String = "http://schemas.microsoft.com/mapi/proptag/"
     sFilter = "@SQL=(" & Chr(34) & PropTag _
            & "0x0037001E" & Chr(34) & " like '%" & strKeyword & "%')" ' OR " & Chr(34) & PropTag _
            & "0x1000001f" & Chr(34) & " like '%" & strKeyword & "%')"
     'Debug.Print sFilter
    
     'Restrict the last set of filtered items for the subject
     Set oFinalItems = ResItems.Restrict(sFilter)
    
     'Sort and collect final results
     oFinalItems.Sort "[Start]"
    
    strAppt = ""
    If oFinalItems.Count > 0 Then
        For Each OAppt In oFinalItems
          With OAppt
            If .Start >= dStart And .Start <= dEnd Then
                strList = Split(OAppt.Subject, "-")
                strData(0) = nameFolder
                strData(1) = Format(.Start, "d-mmm-yyyy")
                strData(2) = Format(.Start, "hh:nn AMPM")
                strData(3) = Format(.End, "hh:nn AMPM")
                strData(4) = Trim(CStr(strList(2)))
                strData(5) = Trim(CStr(strList(3)))
                strData(6) = .Location
                
                strAppt = Join(strData, "~~") & vbCrLf & strAppt
            End If
          End With
        Next
    Else
        strAppt = ""
    End If
    
    strResults = strAppt 'iNumRestricted & " matching Appointment found in " & strName & vbCrLf & strAppt
    
    Set itm = Nothing
    Set newAppt = Nothing
    Set ResItems = Nothing
    Set CalItems = Nothing
    Set CalFolder = Nothing
End Sub
 

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Have not tested it yet... but is the calendar selected? Try selecting it -
set objNavFolder.IsSelected = True


Set objNavFolder = objGroup.NavigationFolders.Item(i)
'If objNavFolder.IsSelected = True Then
set objNavFolder.IsSelected = True
strResults = ""
Set CalFolder = objNavFolder.folder
 

Chooriang

Member
Outlook version
Outlook 2010 64 bit
Email Account
Outlook.com (as MS Exchange)
Thanks, Diane, It works, but some items are duplicate because two or more shared calendars have the same item.
Could we identify if it's the same item even though they are in the different shared calendar folders?
Do the items share the same ID?
 
Similar threads
Thread starter Title Forum Replies Date
D Redemption? Need rapid pull of Outlook Contacts, email + notes for VBA Using Outlook 1
J Pull an email address from body and replace reply-to address Outlook VBA and Custom Forms 4
C Subject Line - Pull Down (Customizeable) Menu Outlook Wishlist 1
M rule to change subject, pull email addresses from body, and forward with templ Using Outlook 14
A Pull mail without marking and processing, only by selecting it Using Outlook 1
J multiple email accounts, but only want to pull from two Using Outlook 1
Commodore Back/Forward toolbar buttons with pull-down history? Using Outlook 5
E Pull Data From Non-Default Calendar Outlook VBA and Custom Forms 2
witzker print-list-of-outlook-folders with sort posibility Outlook VBA and Custom Forms 5
witzker Open Contact missing in Outlook 2019 Using Outlook 2
D.Moore VB script to Digitaly Sign newly created outlook message Outlook VBA and Custom Forms 2
B Outlook 2016 Retail C2R keeps logging since update? Using Outlook 0
M outlook 365 trying to finish my sentences Using Outlook 0
D Outlook Address Book Using Outlook 0
B Emails get stuck in Outbox of Gmail IMAP in Outlook for Windows Using Outlook 0
C Not sync folders not found after MS Outlook 365 update Using Outlook 1
V Outlook 2016 Does Outlook-2016 (64 bit) work with iCloud for Windows ? Using Outlook 4
R Microsoft Outlook 2016 - Gmail not sending, asks for password for SMTP, tried different ports Using Outlook 23
V Outlook 2016 Outlook-2016 and iCloud for Windows - Problems Using Outlook 2
O VBA Outlook Message Attachment - Array Index Out of Bounds Outlook VBA and Custom Forms 0
K Imap PC Outlook + Android phone Using Outlook 1
GregS Outlook 2016 Move Outlook to new computer? Using Outlook 4
I Outlook 2003 shows html code when To: field is empty Using Outlook 7
O The Outlook API wrongfully shows an outlook folder to have zero sub-folders Outlook VBA and Custom Forms 1
O The Outlook API wrongfully shows an outlook folder to have zero sub-folders Outlook VBA and Custom Forms 2
C All Gmails don't show in Outlook 2019 Using Outlook 3
D Outlook 2007 vs. Outlook 2010 -- ToDo Bar Using Outlook 0
U Outlook 2016 Outlook 2016 sender name Using Outlook 1
T Compuserve, Yahoo, Oath2 and Outlook 2013 Using Outlook 4
E Work uses live accounts for emails for all employees. Can we use the outlook calendar to give the employees an universal work schedule calendar? Using Outlook 1
witzker Macro to move @domain.xx of a Spammail to Blacklist in Outlook 2019 Outlook VBA and Custom Forms 7
D Outlook 2007 on 365 Using Outlook.com accounts in Outlook 2
S Macro for other actions - Outlook 2007 Outlook VBA and Custom Forms 23
P outlook 2008 search box criteria couldn't be saved Using Outlook 2
pcunite Outlook 2019/O365 Build 13127.20408 errors when using MAPI calls Using Outlook 1
C Outlook with Office365 - search across account, by date rate, in multiple folders - how? Using Outlook 2
D Outlook 2010 Outlook in Windows 10 keeps asking for user name and password repeatedly Using Outlook 14
S Outlook mail adressing stops after first match in GAL Using Outlook 0
A Apply Selected Emails to outlook rules and Run Rules Using Outlook 5
T Changing Sent Items location in Outlook 2019 Using Outlook 0
J How do I disable advertising in Outlook 2019? Using Outlook 13
S Outlook (2016 32bit; Gmail IMAP) - Save sent message to Outllook Folder Outlook VBA and Custom Forms 0
L Unable to Sync Web/Android MS To Do with Windows Outlook Tasks Using Outlook 3
S Macro to move “Re:” & “FWD:” email recieved the shared inbox to a subfolder in outlook Outlook VBA and Custom Forms 0
S Outlook Macro to send auto acknowledge mail only to new mails received to a specific shared inbox Outlook VBA and Custom Forms 0
S Outlook Macro to move reply mail based on the key word in the subjectline Outlook VBA and Custom Forms 0
B Outlook Calendar not coming down from cloud Using Outlook 2
Terry Sullivan Sender's Name Doesn't Appear in the From Field on Outlook 365/IMAP Using Outlook 2
GregS Outlook 2016 Can I disable the Outlook Outbox? Using Outlook 2
P Outlook pst file is too huge with POP3. How to save more space? Using Outlook 4

Similar threads

Top