[英]Shared Calendar with Outlook loaded from Citrix
我在 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
删除第一个On Error Resume Next
(下面的With ws
)并发布代码失败的行。
此外,您提到 Outlook 在 Citrix 服务器上运行。 我希望您在运行 Outlook 的同一个实例中运行此脚本,否则我不确定您期望与 Outlook 实例的通信会如何发生。
我还希望您确实可以访问共享日历,这是您没有明确提及的内容。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.