excel - 延期预约的原“开始日期”
问题描述
希望有人可以提供帮助:)
我使用通过 Microsoft Outlook 约会运行的 VBA 代码，并为每个约会 - 打印一些详细信息 - 到 Excel 表。
如果我将约会的开始日期设置为01-April-2019，然后将该约会推迟到12-April-2019，然后将该约会推迟到15-April-2019- 我的文件夹中有 3 个“约会项目”对象。
我想为文件夹中的每个约会打印 -最初设置的“开始日期” 。
例如：打印第一个约会 - 第一个原始开始日期 ( 01-April-2019)，第一个推迟约会 - 第一个推迟开始日期 ( 12-April-2019)，第二个推迟约会 - 第二个推迟开始日期 ( 15-April-2019)。
但是，当我运行我的代码时 -打印最后一个“开始日期” ( 15-April-2019, 15-April-2019, 15-April-2019)，而不是原始 ( 01-April-2019, 12-April-2019, 15-April-2019) 。
我读了很多关于不同类型的“日期”对象，但找不到正确的。
有人可以帮我吗？
非常感谢！
Sub GetFromOutlook()
'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim OutlookApp As Outlook.Application
Dim OutlookNS As Namespace
Dim Folder As MAPIFolder
Dim oApp As Outlook.Application
Dim oG As Outlook.Folder 'Method for IMAP, as used by Gmail.
Dim oM As Outlook.MeetingItem
Dim oAA As Outlook.AppointmentItem
Dim oI As Outlook.RecurrencePattern
Dim sMsg$, sAdd$
Dim i As Long
Dim j As Long
Set OutlookApp = New Outlook.Application
Set OutlookNS = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNS.GetDefaultFolder(olFolderInbox).Parent.Folders("CCB Meetings")
Dim icon As String
Set oApp = CreateObject("Outlook.Application")
Set oG = OutlookNS.GetDefaultFolder(olFolderInbox).Parent.Folders("CCB Meetings")
For i = 1 To oG.Items.Count
If TypeName(oG.Items(i)) = "MeetingItem" Then j = j + 1
Next i
If j = 0 Then Exit Sub
' Create titles
Range("A1").Offset(0, 0).Value = "SenderName"
Range("B1").Offset(0, 0).Value = "Subject"
Range("C1").Offset(0, 0).Value = "CreationTime (Scheduled time of the first appointment)"
Range("D1").Offset(0, 0).Value = "ReceivedTime (Scheduled time of the current appointment)"
Range("E1").Offset(0, 0).Value = "Start (start time of the last scheduled appointment)"
Range("F1").Offset(0, 0).Value = "StartTime (doesnt work yet)"
Range("G1").Offset(0, 0).Value = "Location"
Range("H1").Offset(0, 0).Value = "RequiredAttendees"
Range("I1").Offset(0, 0).Value = "OptionalAttendees"
Range("J1").Offset(0, 0).Value = "ResponseStatus"
On Error Resume Next
j = 0
For i = 1 To oG.Items.Count
Set oM = oG.Items(i)
With oG.Items(i).GetAssociatedAppointment(True)
j = j + 1
Range("A1").Offset(j, 0).Value = oM.SenderName
Range("B1").Offset(j, 0).Value = oM.Subject
Range("C1").Offset(j, 0).Value = .CreationTime
Range("D1").Offset(j, 0).Value = oM.ReceivedTime
Range("E1").Offset(j, 0).Value = .Start
Range("F1").Offset(j, 0).Value = oAA.GetRecurrencePattern '??????????????????
Range("G1").Offset(j, 0).Value = .Location
Range("H1").Offset(j, 0).Value = .RequiredAttendees
Range("I1").Offset(j, 0).Value = .OptionalAttendees
Range("J1").Offset(j, 0).Value = .ResponseStatus
End With
Next i
On Error GoTo 0
Set Folder = Nothing
Set OutlookNS = Nothing
Set OutlookApp = Nothing
End Sub
解决方案
我刚刚注意到尼顿的最新评论。我认为这是一个有趣的想法。我怀疑您仍然需要我的调查宏，并且您仍然需要事件来创建自定义属性，所以这个答案应该仍然有用。
我需要投入比目前更多的时间来满足您的要求。这个答案包括我必须交出的内容，希望对您有所帮助。
您的代码表明您不了解经常性条目，您不熟悉不同类型的日历项目，并且您误解了某些属性。如果有任何关于可通过 Internet 获得的日历项目的详细文档，我无法找到它。有基本文档（参考下面）：这个对象有这些属性；该属性是一个长/字符串/枚举；一句话定义等等。但是这些基本文档都没有帮助我理解例如与主条目相关的异常。
下面的代码是我几个月前进行的基于 Excel 的调查。我还没有时间进入下一阶段，但我相信它会给你一个开始。
Option Explicit
Sub DiagCal()
' Outputs major properties of all calendar items within the default
' calendar for a specified date range. The objective is to better
' understand calendar items and how they link.
' Requires reference to Microsoft Outlook nn.n Library
' where "nn.n" identifies the version of Office you are using.
' 27Dec18 First version coded
' 30Dec18 This version coded
' 18Apr19 Reviewed comments and made some improvements.
' * Together these constants identify the start and length of the report period.
' * The report period starts DateReportStartOffset days before today.
' * DateReportLenType and DateReportLen are used as parameters for function DateAdd
' which is used to calculate the report period end date for the start date. See
' function DateAdd for permitted values for these constants.
' * These constants provided a convenient way of specify the start and end date
' of the report period when this macro was written. Something simpler would
' probably be better now.
Const DateReportLen As Long = 1
Const DateReportLenType As String = "yyyy"
Const DateReportStartOffset As Long = -363
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.
' Change as necessary
Set FldrCal = AppOutlook.Session.GetDefaultFolder(olFolderCalendar)
' This loop reviews the entire calendar and identifies Calendar Items
' that fall entirely or partially within the report period. All such
' Calendar Items are recorded in collection AppointToReport.
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
' This loop outputs the major properties of every Calendar Items recorded
' in collection AppointToReport.
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
创建启用宏的工作簿并将上述代码复制到模块。
在代码顶部附近，您会发现：
' Identify date range to be reported on
DateReportStart = DateSerial(Year(Now), Month(Now), Day(Now) + DateReportStartOffset)
DateReportEnd = DateAdd(DateReportLenType, DateReportLen, DateReportStart)
我建议用简单的东西替换这些语句，例如：
DateReportStart = #4/15/2019#
DateReportEnd = #4/18/2019#
警告：VBA 日期文字使用中端格式，这会使除了美国平民之外的所有人都感到困惑。
宏DiagCal()创建一个名为“Calendar.txt”的桌面文件，其中包含全部或部分在报告期间内的每个日历项目的详细信息。当我测试它时，我创建了各种日历条目：单个约会；按日、周、月、年重复出现的条目；每周模式；多天、全天和部分天的活动；重复条目实例的例外情况等等。
访问https://docs.microsoft.com/en-us/office/vba/api/Outlook.AppointmentItem
左侧是一个索引，其中包含约会项目的事件、方法和属性的条目。展开属性和方法，查找我不感兴趣但您可能感兴趣的信息。查看我的代码并练习如何添加该信息。如果您看不到如何添加信息，请在评论中报告您想要的信息，我会为您添加。
展开活动并研究可用的内容。我从未使用过约会项目事件。我发现事件很容易与邮件项目一起使用，所以我认为约会项目将是相似的。我还不清楚哪个是最好的事件。我认为您需要知道何时添加新项目以及何时更改项目。我会尝试其中一些事件并编写代码以将一些属性输出到即时窗口，以更好地了解这些事件何时触发以及哪些数据可用。
我相信您将不得不使用类似于我的宏的代码来初始化您的工作簿，该宏会提取现有约会项目的有趣属性。然后，您需要事件来输出新的或更改的事件的有趣属性。
我不会使用事件来更新工作簿。(1) 如果您实时更新工作簿，则在处理事件时可能会有明显的延迟。(2) 更新代码可能很复杂，第一次尝试时不太可能正确。如果您实时更新工作簿，您将不得不一次又一次地触发事件，直到您获得正确的代码。
我会让每个事件输出一个包含有趣属性的小文本文件到合适的磁盘文件夹。输出文本文件将花费很少的时间，并且不会引起用户注意。可以一次又一次地使用这些文本文件来更新工作簿，直到您获得正确的代码。
希望以上内容能给大家一些思路。
推荐阅读
- arrays - 如何使 SPARKLINE 折线图仅动态显示过去 7 天和其他时间段？
- python - 有没有办法在熊猫中使用方法/函数作为 .loc() 的表达式？
- python - Django/Wagtail - 如何在模板中创建一个条件来检查 url 路径？
- asp.net-core - 身份令牌重置密码 ASP.NET Core 3.1 的问题
- android - 如图所示，如何实现交错布局管理器的高度
- javascript - ngClass 和 onClick 不适用于 Div
- javascript - 如何在更新用户密码时验证旧密码？
- javascript - 按对象属性（对象数组）获取平均值的最有效方法
- android - MediaSession.SetMetadata 在蓝牙设备上不起作用
- arrays - Rails 如何从嵌套的 JSON 数据中提取数据