vba - Exchange 用户 FreeBusy 信息，包括定期约会
问题描述
我正在尝试获取FreeBusy一些 Outlook Exchange 用户的信息，其中包括他们（和我的）定期约会。
我可以让代码为普通约会工作，但是当我还尝试确保人们不在重复约会中时被卡住了（它不会通过空闲忙碌功能返回）。
Public Sub GetFreeBusyForAPerson()
Dim usersList As Outlook.AddressEntries
Dim oEntry As Outlook.AddressEntry
Dim oContact As Object
Set usersList = Outlook.Application.Session.AddressLists.Item("All Users").AddressEntries
Set oEntry=usersList.Item("Jones; Jonathan")
Debug.Print
Mid(oEntry.GetExchangeUser().GetFreeBusy(CDate("08/01/2019"), 60, False), 1, 48)
End Sub
我回来了000000000000000000000000000000000000000000000000
，我知道此人在相关日期有定期约会，但未显示。
解决方案
我发现你的问题很有趣。我无权访问，GetExchangeUser().GetFreeBusy因此无法知道您是否正确使用了该方法。也许有相关知识的人会让你正确。但是，如果问题出在GetFreeBusy，是否有另一种方法可以为您提供所需的功能。自从我玩日历项目以来已经有好几年了，我认为更新我的知识会很有趣。
我记得我可以访问同事的日历。但如果这是不可能的，还有什么替代方案可用？在多个系统上安装 Outlook 宏不能自动化，所以我想我会尝试 Excel。可以轻松分发包含 Outlook 访问宏的 Excel 工作簿。该宏能否访问默认日历、提取您需要的信息并通过电子邮件发送给您？这不是一个理想的解决方案，但如果它有效，我相信它会提供可接受的次优解决方案。如果可行，则在 Excel 中开发的代码可以作为 Outlook 宏分发，并链接到在您发送包含特定主题的电子邮件时激活宏的规则。这将使您对流程的控制几乎与您希望对当前解决方案的控制一样多。
关键问题是：Excel 宏能否访问 Outlook 日历中的所有数据？访问日历证明比我预期的要容易。但是，由于我发现文档令人困惑，因此发现重复项目的例外情况被证明是很棘手的。但是，通过仔细使用 Debug 的 Watch 来研究 anAppointmentItem和 a recurringAppointmentItem的内容，RecurringPattern我能够发现异常的存储位置。
当我完成我的调查宏时，德米特里已经表示GetFreeBusy可以处理定期约会。阅读他对其他问题的回答，很明显他具有相当的专业知识，所以我倾向于相信他。他想知道是否CDate("08/01/2019")没有创建您期望的日期。从您的回复来看，这似乎不太可能。你可以试试。DateSerial(2019, 1, 8)这将消除任何歧义，但我怀疑这是问题所在。
我认为我的调查宏会有所帮助。我只在我的日历条目上对其进行了测试，因此可能需要进一步调试。您AppointmentItem的 s 将包含我没有的属性，因此您可能需要增强我的宏。
我的宏由三个常量控制：
Const DateReportLen As Long = 1 '\ Together identify the length of
Const DateReportLenType As String = "yyyy" '/ the report period
Const DateReportStartOffset As Long = -363 '\ The offset from today to the start of
'| the report period. Set to a positive
'/ value for a date in the future
宏的报告期开始于Now() + DateReportStartOffset。-365 的值允许有一个从 2018 年 1 月 1 日开始的期间。这两个DateReportLen常量允许我将期间结束日期设置为开始日期之后的一年。您将需要调整这些值，以便仅在 2019 年 1 月 8 日或可能在任一方的几天内报告。
该宏会在您的桌面上创建一个名为“Calendar.txt”的文件。如果您愿意，可以更改位置和名称。该文件包含我认为与AppointmentItem报告期内或部分报告期内的所有财产相关的所有财产。通过检查这些属性，您可能会发现您同事的日历与您预期的不同。
请注意，如果 Outlook 打开，我的宏似乎不起作用。我没有调查过这个问题
宏需要引用“Microsoft Outlook nn.n 库”，其中“nn.n”标识您正在使用的 Office 版本。
输出文件的宏需要引用“Microsoft ActiveX Data Objects nn Library”。“nn”多年来一直是“6.1”。
Option Explicit
Sub DiagCal()
' Requires reference to Microsoft Outlook nn.n Library
' where "nn.n" identifies the version of Office you are using.
Const DateReportLen As Long = 1 '\ Together identify the length of
Const DateReportLenType As String = "yyyy" '/ the report period
Const DateReportStartOffset As Long = -363 '\ The offset from today to the start of
'| the report period. Set to a positive
'/ value for a date in the future
Dim AppointToReport As New Collection
Dim AppOutlook As New Outlook.Application
Dim CalEnt As Object
Dim CalEntClass As Long
Dim DateReportEnd As Date
Dim DateReportStart As Date
Dim FileBody As String
Dim FldrCal As Outlook.Folder
Dim InxAir As Long
Dim InxFC As Long
Dim PathDesktop As String
PathDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' Identify date range to be reported on
DateReportStart = DateSerial(Year(Now), Month(Now), Day(Now) + DateReportStartOffset)
DateReportEnd = DateAdd(DateReportLenType, DateReportLen, DateReportStart)
' This assumes the calendar of interest is the default calendar.
' This is almost certainly true.
Set FldrCal = AppOutlook.Session.GetDefaultFolder(olFolderCalendar)
For InxFC = 1 To FldrCal.Items.Count
Set CalEnt = FldrCal.Items(InxFC)
' Occasionally I get syncronisation errors. This code avoids them.
CalEntClass = -1
On Error Resume Next
CalEntClass = CalEnt.Class
On Error GoTo 0
' I have never found anything but appointments in
' Calendar but test just in case
If CalEntClass = olAppointment Then
Call DiagCalRecordEntry(CalEnt, DateReportStart, DateReportEnd, AppointToReport)
End If
Next InxFC
FileBody = "Calendar entries within or partially within " & _
Format(DateReportStart, "d mmm yy") & _
" to " & Format(DateReportEnd, "d mmm yy") & vbLf & _
"Total calendar entries: " & FldrCal.Items.Count & vbLf & _
"Calendar entries within or partially within report period: " & _
AppointToReport.Count
For InxAir = 1 To AppointToReport.Count
FileBody = FileBody & vbLf & String(70, "=")
FileBody = FileBody & vbLf & AppointToReport(InxAir)(1)
Next
Call PutTextFileUtf8NoBom(PathDesktop & "\Calendar.txt", FileBody)
End Sub
Sub DiagCalRecordEntry(ByRef CalEnt As Object, _
ByVal DateReportStart As Date, _
ByVal DateReportEnd As Date, _
ByRef AppointToReport As Collection, _
Optional ByVal OriginalDate As Date)
' If calendar entry is within or partially within report range, add
' its details to AppointToReport
Dim AllDayEvent As Boolean
Dim AppointDtls As String
Dim AppointId As String
Dim AppointIdMaster As String
Dim BusyStatus As String
Dim DateRecurrEnd As Date
Dim DateRecurrStart As Date
Dim DateAppointEnd As Date
Dim DateAppointStart As Date
Dim DayOfMonth As Long
Dim DayOfWeekMask As String
Dim DayOfWeekMaskCode As Long
Dim DurationEntry As Long
Dim DurationRecurr As Long
Dim InxE As Long
Dim Instance As Long
Dim Interval As Long
Dim Location As String
Dim MonthOfYear As Long
Dim NoEndDate As Boolean
Dim NumOccurrences As Long
Dim RecurrenceState As String
Dim RecurrenceType As String
Dim RecurrPattern As Outlook.RecurrencePattern
Dim Subject As String
Dim TimeStart As Date
Dim TimeEnd As Date
'Debug.Assert False
' Get values from calendar entry which identify if entry is within
' report range
With CalEnt
DateAppointStart = .Start
DateAppointEnd = .End
Select Case .RecurrenceState
Case olApptNotRecurring
'Debug.Assert False
RecurrenceState = "Non-recurring calendar entry"
Case olApptMaster
'Debug.Assert False
RecurrenceState = "Master calendar entry"
Case olApptException
'Debug.Assert False
RecurrenceState = "Exception to Master calendar entry"
Case olApptOccurrence
Debug.Assert False
' I believe this state can only exist if GetOccurrence() is used
' to get a single occurrence of a Master entery. I do not believe
' it can appear as a calendar entry
RecurrenceState = "Occurrence"
Case Else
Debug.Assert False
RecurrenceState = "Unrecognised (" & .RecurrenceState & ")"
End Select
End With
If RecurrenceState = "Master calendar entry" Then
'Debug.Assert False
Set RecurrPattern = CalEnt.GetRecurrencePattern()
With RecurrPattern
DateRecurrStart = .PatternStartDate
DateRecurrEnd = .PatternEndDate
End With
If DateRecurrStart <= DateReportEnd And _
DateRecurrEnd >= DateReportStart Then
' Some or all occurences of this Master entry are within report range
'Debug.Assert False
Else
' No occurences of this Master entry are within report range
'Debug.Assert False
Exit Sub
End If
Else
' Non recurring or exception appointment
If DateAppointStart <= DateReportEnd And _
DateAppointEnd >= DateReportStart Then
' Entry is within report range
'Debug.Assert False
Else
' Non recurring entry is not within report range
'Debug.Assert False
Exit Sub
End If
End If
' Calendar entry is within or partially within report period
' Get remaining properties from entry
'Debug.Assert False
With CalEnt
AllDayEvent = .AllDayEvent
AppointId = .GlobalAppointmentID
Select Case .BusyStatus
Case olBusy
'Debug.Assert False
BusyStatus = "Busy"
Case olFree
'Debug.Assert False
BusyStatus = "Free"
Case olOutOfOffice
'Debug.Assert False
BusyStatus = "Out of Office"
Case olTentative
Debug.Assert False
BusyStatus = "Tentative appointment"
Case olWorkingElsewhere
'Debug.Assert False
BusyStatus = "Working elsewhere"
Case Else
Debug.Assert False
BusyStatus = "Not recognised (" & .BusyStatus & ")"
End Select
Location = .Location
Subject = .Subject
End With
If RecurrenceState = "Exception to Master calendar entry" Then
RecurrenceState = RecurrenceState & vbLf & _
"Master's Id: " & CalEnt.Parent.GlobalAppointmentID & vbLf & _
"Original Date: " & OriginalDate
End If
AppointDtls = RecurrenceState & vbLf & _
"AllDayEvent: " & AllDayEvent & vbLf & _
"AppointId: " & AppointId & vbLf & _
"BusyStatus: " & BusyStatus & vbLf & _
"DateAppointStart: " & DateAppointStart & vbLf & _
"DateAppointEnd: " & DateAppointEnd & vbLf & _
"DurationEntry: " & DurationEntry & vbLf & _
"Location: " & Location & vbLf & _
"Subject: " & Subject
If RecurrenceState <> "Master calendar entry" Then
' AppointDtls complete for this appointment
Call StoreSingleAppoint(Format(DateAppointStart, "yyyymmddhhmm"), _
AppointDtls, AppointToReport)
Else
'Debug.Assert False
With RecurrPattern
' Not all parameters have a meaningful value for all RecurrenceTypes
' but the value always appears to be of the correct data type.
DateRecurrStart = .PatternStartDate
DateRecurrEnd = .PatternEndDate
DayOfMonth = .DayOfMonth
DayOfWeekMaskCode = .DayOfWeekMask
DayOfWeekMask = ""
If DayOfWeekMaskCode >= olSaturday Then
Debug.Assert False
DayOfWeekMask = "+Saturday"
DayOfWeekMaskCode = DayOfWeekMaskCode - olSaturday
End If
If DayOfWeekMaskCode >= olFriday Then
'Debug.Assert False
DayOfWeekMask = "+Friday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olFriday
End If
If DayOfWeekMaskCode >= olThursday Then
'Debug.Assert False
DayOfWeekMask = "+Thursday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olThursday
End If
If DayOfWeekMaskCode >= olWednesday Then
'Debug.Assert False
DayOfWeekMask = "+Wednesday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olWednesday
End If
If DayOfWeekMaskCode >= olTuesday Then
'Debug.Assert False
DayOfWeekMask = "+Tuesday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olTuesday
End If
If DayOfWeekMaskCode >= olMonday Then
'Debug.Assert False
DayOfWeekMask = "+Monday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olMonday
End If
If DayOfWeekMaskCode >= olSunday Then
'Debug.Assert False
DayOfWeekMask = "+Sunday" & DayOfWeekMask
End If
If DayOfWeekMask = "" Then
'Debug.Assert False
DayOfWeekMask = "None"
Else
'Debug.Assert False
DayOfWeekMask = Mid$(DayOfWeekMask, 2) ' Remove leading +
End If
DurationRecurr = .Duration
Instance = .Instance
Interval = .Interval
MonthOfYear = .MonthOfYear
NoEndDate = .NoEndDate
NumOccurrences = .Occurrences
Select Case .RecurrenceType
Case olRecursDaily
'Debug.Assert False
RecurrenceType = "Daily"
Case olRecursMonthly
Debug.Assert False
RecurrenceType = "Monthly"
Case olRecursMonthNth
Debug.Assert False
RecurrenceType = "MonthNth"
Case olRecursWeekly
'Debug.Assert False
RecurrenceType = "Weekly"
Case olRecursYearly
'Debug.Assert False
RecurrenceType = "Yearly"
Case olRecursYearNth
Debug.Assert False
RecurrenceType = "YearNth"
Case Else
Debug.Assert False
RecurrenceType = "Unrecognised Value (" & RecurrenceType & ")"
End Select
TimeStart = .StartTime
TimeEnd = .EndTime
End With
AppointDtls = AppointDtls & vbLf & "DateRecurrStart: " & DateRecurrStart _
& vbLf & "DateRecurrEnd: " & DateRecurrEnd _
& vbLf & "DayOfMonth: " & DayOfMonth _
& vbLf & "DayOfWeekMask: " & DayOfWeekMask _
& vbLf & "DurationRecurr: " & DurationRecurr _
& vbLf & "Instance: " & Instance _
& vbLf & "Interval: " & Interval _
& vbLf & "MonthOfYear: " & MonthOfYear _
& vbLf & "NoEndDate: " & NoEndDate _
& vbLf & "NumOccurrences: " & NumOccurrences _
& vbLf & "RecurrenceType: " & RecurrenceType _
& vbLf & "TimeStart: " & TimeStart & " (" & CDbl(TimeStart) & ")" _
& vbLf & "TimeEnd: " & TimeEnd & " (" & CDbl(TimeEnd) & ")"
For InxE = 1 To RecurrPattern.Exceptions.Count
AppointDtls = AppointDtls & vbLf & "Exception " & InxE & " for occurrence on " & _
RecurrPattern.Exceptions.Item(InxE).OriginalDate
Next
Call StoreSingleAppoint(Format(DateRecurrStart, "yyyymmddhhmm"), _
AppointDtls, AppointToReport)
For InxE = 1 To RecurrPattern.Exceptions.Count
Call DiagCalRecordEntry(RecurrPattern.Exceptions.Item(InxE).AppointmentItem, _
DateReportStart, DateReportEnd, AppointToReport, _
RecurrPattern.Exceptions.Item(InxE).OriginalDate)
Next
End If ' RecurrenceState <> "Master calendar entry"
End Sub
Public Sub PutTextFileUtf8NoBom(ByVal PathFileName As String, ByVal FileBody As String)
' Outputs FileBody as a text file named PathFileName using
' UTF-8 encoding without leading BOM
' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
' Addition to original code says version 2.5. Tested with version 6.1.
' 1Nov16 Copied from http://stackoverflow.com/a/4461250/973283
' but replaced literals with parameters.
' 15Aug17 Discovered routine was adding an LF to the end of the file.
' Added code to discard that LF.
' 11Oct17 Posted to StackOverflow
' 9Aug18 Comment from rellampec suggested removal of adWriteLine from
' WriteTest statement would avoid adding LF.
' 30Sep18 Amended routine to remove adWriteLine from WriteTest statement
' and code to remove LF from file. Successfully tested new version.
' References: http://stackoverflow.com/a/4461250/973283
' https://www.w3schools.com/asp/ado_ref_stream.asp
Dim BinaryStream As Object
Dim UTFStream As Object
Set UTFStream = CreateObject("adodb.stream")
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
UTFStream.WriteText FileBody
UTFStream.Position = 3 'skip BOM
Set BinaryStream = CreateObject("adodb.stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
UTFStream.CopyTo BinaryStream
UTFStream.Flush
UTFStream.Close
Set UTFStream = Nothing
BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
Set BinaryStream = Nothing
End Sub
Sub StoreSingleAppoint(ByVal SeqKey As String, _
ByVal AppointDtls As String, _
ByRef AppointToReport As Collection)
' Entries in AppointToReport are of the form:
' VBA.Array(SeqKey, AppointDtls)
' Add new entry to AppointToReport so entries are in ascending order by SeqKey
Dim InxAtr As Long
If AppointToReport.Count = 0 Then
'Debug.Assert False
' first appointment
AppointToReport.Add VBA.Array(SeqKey, AppointDtls)
Else
For InxAtr = AppointToReport.Count To 1 Step -1
If SeqKey >= AppointToReport(InxAtr)(0) Then
' New appointment belongs after this existing entry
'Debug.Assert False
AppointToReport.Add VBA.Array(SeqKey, AppointDtls), , , InxAtr
Exit Sub
End If
Next
' If get here, new appointment belongs before all existing appointments
'Debug.Assert False
AppointToReport.Add VBA.Array(SeqKey, AppointDtls), , 1
End If
End Sub
推荐阅读
- java - 在java中合并数组
- python-3.x - Pandas：使用“DatetimeIndex”时处理偏移时区值
- objective-c - Objective-C 排序函数中是否有类似 yield 的东西？
- java - 如何在 Java 对象中表示外键
- python - 分配给临时字典然后是最终字典 - 优势？
- java - 获取用户输入计数
- python - 时间序列 Python 中每小时数据的箱线图
- php - 如何在 Angular 和 PHP 的帮助下检索表格行中的超链接？
- c - 使用 libfuzzer 在小端环境中对大端代码进行模糊测试
- java - Byte Buddy - 如何委托私有方法？