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.
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:
