与从 Citrix 加载的 Outlook 共享日历

Question

我在 Excel 中有以下功能可以访问 Outlook 中的共享日历文件夹并列出指定日期范围内的所有特定约会（从其主题中识别）。 由于 Outlook 是从 Citrix 服务器加载的，因此代码似乎无法按预期工作。 我对此不太确定，需要有人帮助解决这个问题。

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

Answer 1

删除第一个 On Error Resume Next（With ws 下面的那个）并发布代码失败的行。

另外，您提到 Outlook 在 Citrix 服务器上运行。我希望您在运行 Outlook 的同一实例中运行此脚本，否则我不确定您希望如何与 Outlook 实例进行通信。

我还希望您确实可以访问共享日历，这是您没有明确提及的。