Я только что заметил последний комментарий Нитона.Я думаю, что это интересная идея.Я подозреваю, что вам все еще нужен мой макрос расследования, и вам все еще понадобятся события для создания пользовательского свойства, поэтому этот ответ все еще должен быть полезен.
Мне нужно потратить больше времени, чем у меня есть на данный момент, чтобы удовлетворить ваши требования.Этот ответ включает в себя то, что я должен передать в надежде, что это поможет вам.
Ваш код предполагает, что вы не понимаете повторяющиеся записи, вы не знакомы с различными типами элементов календаря и неправильно истолковали некоторые из них.свойства.Если есть какая-либо подробная документация по элементам календаря, доступная через Интернет, я не смог ее найти.Существует базовая документация (ссылка ниже): этот объект обладает этими свойствами;это свойство long / string / enumeration;определения одного предложения и так далее.Но ни одна из этой базовой документации не помогла мне понять, как, например, исключения, связанные с основными записями.
Приведенный ниже код - это исследование на основе 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
Слева находится указатель с записями для событий, методов и свойств элемента назначения.Разверните свойства и методы и найдите информацию, которая меня не интересует, но может вас заинтересовать.Посмотрите мой код и тренировки, как добавить эту информацию.Если вы не видите, как добавить информацию, сообщите о ней нужную информацию в комментарии, и я добавлю ее для вас.
Разверните события и изучите доступные возможности.Я никогда не использовал события пункта назначения.Я обнаружил, что события достаточно легко использовать с почтовыми отправлениями, поэтому я предполагаю, что они будут похожиМне не сразу понятно, какие из них лучше всего использовать.Я думаю, вам нужно знать, когда новый элемент добавляется и когда элемент изменяется.Я хотел бы попробовать некоторые из этих событий и написать код для вывода нескольких свойств в Immediate Windows, чтобы лучше понять, когда эти события инициируются и какие данные доступны.
Я полагаю, что вам придется инициализировать вашу книгу с помощью кодачто-то вроде моего макроса, который извлекает интересные свойства существующих элементов назначения.Затем вам нужны события для вывода интересных свойств новых или измененных событий.
Я бы не использовал события для обновления рабочей книги.(1) Если вы обновите книгу в режиме реального времени, вероятно, будет существенная задержка во время обработки события.(2) Код обновления, вероятно, будет сложным и вряд ли будет корректным с первой попытки.Если вы обновляете рабочую книгу в режиме реального времени, вам придется снова и снова запускать события, пока не получите правильный код.
Я бы получал каждое событие для вывода небольшого текстового файла, содержащего интересныйсвойства, в подходящую папку диска.Вывод текстового файла займет немного времени и не должен быть заметен для пользователя.Эти текстовые файлы можно использовать снова и снова для обновления книги до тех пор, пока вы не получите правильный код.
Надеюсь, вышеизложенное даст вам некоторые идеи.