Мой общий ответ превышает ограничение StackOverflow в 30 000 символов, поэтому я разделил ответ на два
Часть 2
При более детальной проверке я нашел свой второй макрос не содержит ошибки; это было незакончено. Мне кажется, я разработал его достаточно далеко, чтобы найти то, что мне нужно было знать, а затем отказался от него.
Я уже закончил этот макрос. Вероятно, он содержит все необходимое для первой проблемы в моем списке: Как найти элементы календаря на период, который я sh должен проанализировать?
Найти элементы календаря, которые вы хотите проанализировать, sh сложнее чем вы могли ожидать. Одноразовая встреча приведет к единственному AppointmentItem в вашем календаре. Это AppointmentItem будет содержать все, что вам нужно знать о встрече. В частности, он содержит свойства Start и End, которые позволят провести простую проверку диапазона отчета. Это повторяющиеся встречи, которые сложно.
Предположим, у меня есть регулярные встречи команды во вторник и четверг. Я внесу go в свой календарь и назначу встречу на четверг, 2 января 2020 года. Я введу название, местоположение, категории. Затем я нажму [Повторение]. Я нажму (Еженедельно), если он еще не выбран в качестве шаблона повторения. Четверг будет отмечен. Я буду отмечать вторник. Я изменю дату окончания на четверг, 31 декабря 2020 года. Теперь в моем календаре назначены встречи на каждый вторник и четверг на весь год. У меня забронированы праздничные дни на июнь, поэтому я буду удалять соответствующие записи. Позже я получаю сообщение о том, что определенное собрание должно быть на полчаса позже обычного и находится в другой комнате для собраний. Я изменю детали на соответствующий день.
Если макрос VBA просматривает мой календарь, он найдет одну встречу Мастера на 2 января 2020 года. Встреча Мастера - та, которая повторяется. Макрос использует GetRecurrencePattern(), чтобы получить подробности повторения встречи. Шаблон повторения также записывает все исключения.
100 или около того записей в моем календаре были сгенерированы из одного AppointmentItem. Чтобы решить, какие из этих записей находятся в пределах отчетного периода, мой макрос создает массив, содержащий 5 и 2. Он начинается с четверга 2 января 2020 года, затем идет вперед на 5 дней, затем на 2 дня, затем на 5 дней, затем на 2 дня, затем на 5 дней и т. Д. пока он не пройдет отчетный период. 5-дневный шаг проходит с четверга по вторник. Двухдневный шаг проходит со вторника по четверг. Макрос проверяет каждую дату на период отчета. Если дата находится в пределах отчетного периода, макрос проверяет наличие исключения. Если для даты нет исключений, макрос добавляет обычную запись в коллекцию AppointToReport. Исключением может быть удаление вхождения или изменение вхождения. Для удаления макрос не добавляет в коллекцию. Для изменения добавляется запись, основанная на исключении.
Если последний абзац сбивал вас с толку, вам придется создать несколько тестовых встреч, пройтись по макросу и изучить, что он делает.
В начале я сказал, что начинаю с объектной модели для AppointmentItem. Это полезное начало, но в нем не говорится, какие свойства используются с какими шаблонами повторения. Чтобы обнаружить, что я использую часы. Вы найдете [Окно просмотра] в [View] и [Add Watch] в [Debug]. Я добавил переменные, содержащие AppointmentItem и RecurrencePattern. Это позволило мне понять, как каждое свойство использовалось при различных обстоятельствах.
Макрос ниже представляет собой макрос Excel. Когда вы хотите переместить данные из Outlook в Excel, может быть трудно решить, писать ли макрос в Outlook или Excel, так как код очень похож на оба подхода. Outlook имеет надежную систему безопасности, которая не любит, когда внешние макросы обращаются к своей базе данных, поэтому пользователь должен давать разрешение не реже одного раза в 10 минут. Он не беспокоится о встречах с макросами в Excel, так что это не вопрос для вас. Для меня самые важные соображения: (1) я нахожу среду разработки Excel VBA несколько проще, чем среду разработки Outlook, и (2) проще делиться макросами Excel с коллегами, чем макросами Outlook.
Если вы если вы действительно хотите макрос Outlook, вам придется перекодировать начало моего макроса.
Я уже говорил, что макрос добавляет запись в коллекцию для каждого события в диапазоне отчета. Когда он проверил весь календарь, он выводит содержимое этой коллекции на лист. Для моих тестовых данных вывод:
Записи в коллекции содержат начало, конец, тему, местоположение и категории. Вы можете легко добавить больше значений, если это необходимо. Обратите внимание, что события перечислены в порядке добавления в календарь. Сначала я добавил некоторые встречи с категориями, а затем встречи, которые использовали столько вариантов повторения, сколько я думал, что я должен проверить. Если я правильно понимаю, вы хотите суммировать общее время по категориям, поэтому последовательность не должна иметь значения. Вы должны протестировать макрос, чтобы все AppointmentItem опции, которые вы используете.
Я оставил весь свой тестовый код в макросе, но закомментировал его. Вы можете удалить кавычки, если вы хотите восстановить вывод. Я ставлю Debug.Assert False наверху каждого пути через мой код. Когда этот путь выполняется, я комментирую Debug.Assert False out. Если вы найдете Debug.Assert False без кавычек, это означает, что приведенный ниже код не был проверен.
Option Explicit
Sub InvestigateCalendar()
' Outputs major properties of all calendar items within a calendar for a
' specified date range to desktop file "Calendar.txt". The objective is
' to better understand calendar itens and how they link.
' Requires reference to Microsoft Outlook nn.n Library
' where "nn.n" identifies the version of Office you are using.
' Specify date range to be reported on
Const DateReportStart As Date = #3/1/2020#
Const DateReportEnd As Date = #3/31/2020#
Dim AllDayEvent As Boolean
Dim AppointCrnt As Outlook.AppointmentItem
Dim AppointToReport As New Collection
Dim AppOutlook As New Outlook.Application
Dim CalItemClass As Long
Dim Categories As String
Dim DateAddInterval As String
Dim DateAddNumbers As Variant
Dim DateCrnt As Date
Dim DateEnd As Date
Dim DateStart As Date
Dim DayOfWeekMaskValues As Variant
Dim ExceptionAllDayEvent As Boolean
Dim ExceptionDateEnd As Date
Dim ExceptionDateStart As Date
Dim ExceptionLocation As String
Dim ExceptionNoneForDateCrnt As Boolean
Dim ExceptionSubject As String
Dim FldrCal As Outlook.Folder
Dim InxATR As Long ' Index into AppointToReport array
Dim InxDAN As Long ' Index into DateAddNumbers array
Dim InxDCrnt As Long ' Index into day of week arrays
Dim InxDEnd As Long ' End value for InxDCrnt
Dim InxDStart As Long ' Start value for InxDCrnt
Dim InxE As Long ' Index into exceptions
Dim InxFC As Long ' Index into Calendar folder
Dim IntervalNext As Long
Dim Location As String
Dim MaskCrnt As Long
Dim NumDaysInDayOfWeekMask As Long
Dim OccurrenceInRange As Boolean
Dim PathDesktop As String
Dim RecurrPattern As Outlook.RecurrencePattern
Dim RowCrnt As Long
Dim Subject As String
PathDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' Use this Set if the calendar of interest is the default calendar.
'Set FldrCal = AppOutlook.Session.GetDefaultFolder(olFolderCalendar)
' Use this Set to access a named calendar
Set FldrCal = AppOutlook.Session.Folders("Outlook Data File").Folders("Calendar")
' Change above as necessary
'' Values returned by function Weekday for Sunday to Saturday
'WeekDayValues = VBA.Array(1, 2, 3, 4, 5, 6, 7)
' Values In DayOfWeekMask for Sunday to Saturday
DayOfWeekMaskValues = VBA.Array(1, 2, 4, 8, 16, 32, 64)
' 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
' Occasionally I get syncronisation errors. This code avoids them.
CalItemClass = -1
On Error Resume Next
CalItemClass = FldrCal.Items(InxFC).Class
On Error GoTo 0
' I have never found anything but appointment items in
' Calendar but test just in case
If CalItemClass = olAppointment Then
Set AppointCrnt = FldrCal.Items(InxFC)
With AppointCrnt
Select Case .RecurrenceState
Case olApptNotRecurring
'Debug.Assert False
'Debug.Assert .Subject <> "All day non-recurring"
'Debug.Assert .Subject <> "All day meeting"
If (.Start >= DateReportStart And .Start <= DateReportEnd) Or _
(.End >= DateReportStart And .End <= DateReportEnd) Then
'Debug.Assert False
' Either the start of the appointment is within the report range
' or the end of the appointment is with the report range or
' both start and end are within the report range
'AppointToReport.Add Array(.Start, .End, .Subject, .Location, .Categories)
AppointToReport.Add Array( _
CalcStartDateCrnt(.Start, .Start, .AllDayEvent), _
CalcEndDateCrnt(.Start, .End, .Start, .AllDayEvent), _
.Subject, .Location, .Categories)
Else
If .AllDayEvent Then
'Debug.Assert False
If DateAdd("d", 1, DateValue(.Start)) = DateValue(.End) Then
'Debug.Assert False
'Debug.Print "Non-recurring Out-of-range all day " & DateValue(.Start)
Else
Debug.Assert False
Debug.Print "Non-recurring Out-of-range all day" & _
DateValue(.Start) & "-" & DateValue(.End)
End If
Else
If DateValue(.Start) = DateValue(.End) Then
'Debug.Assert False
'Debug.Print "Non-recurring Out-of-range " & DateValue(.Start) & _
" " & TimeValue(.Start) & " - " & TimeValue(.End)
Else
'Debug.Assert False
'Debug.Print "Non-recurring Out-of-range " & .Start & " - " & .End
End If
End If
End If
Case olApptMaster
'Debug.Assert False
Set RecurrPattern = .GetRecurrencePattern()
DateStart = .Start
DateEnd = .End
AllDayEvent = .AllDayEvent
Location = .Location ' Record for recurring items
Subject = .Subject
'Debug.Assert Subject <> "Test recurring yearly 2 days"
Categories = .Categories
With RecurrPattern
' Not all properties have a meaningful value for all RecurrenceTypes
' but the value always appears to be of the correct data type.
'Debug.Print "Recurr Pattern " & .PatternStartDate & " - " & .PatternEndDate
'For InxE = 1 To .Exceptions.Count
' Debug.Print " Exception " & InxE & " to recurring item " & " for occurrence on " & _
' .Exceptions.Item(InxE).OriginalDate
'Next
'Debug.Assert .PatternStartDate <> #2/12/2020#
If .PatternStartDate >= DateReportEnd Or _
.PatternEndDate <= DateReportStart Then
' All occurrences outside report range
'Debug.Print " All occurences out-of-range"
Else
' For most recurrence types, there is a single interval. For weekly
' recurrences, the DayOfWeekMask there can be several intervals
If .RecurrenceType = olRecursYearly Then
'Debug.Assert False
' Set parameters for DateAdd
DateAddInterval = "yyyy"
' .Interval is the interval between occurrences in months
DateAddNumbers = VBA.Array(.Interval / 12)
ElseIf .RecurrenceType = olRecursYearNth Then
' I cannot discover how to create an appointment item with this
' RecurrenceType. Is it obsolete?
Debug.Assert False
DateAddInterval = "yyyy"
DateAddNumbers = VBA.Array(1) ' #### Fix if ever get this recurrence type
ElseIf .RecurrenceType = olRecursMonthly Then
'Debug.Assert False
DateAddInterval = "m"
DateAddNumbers = VBA.Array(.Interval)
ElseIf .RecurrenceType = olRecursMonthNth Then
' I cannot discover how to create an appointment item with this
' RecurrenceType. Is it obsolete?
Debug.Assert False
DateAddInterval = "m"
DateAddNumbers = VBA.Array(1) ' #### Fix if ever get this recurrence type
ElseIf .RecurrenceType = olRecursWeekly Then
'Debug.Assert False
DateAddInterval = "d" ' Step by days not weeks
MaskCrnt = 1
NumDaysInDayOfWeekMask = 0
' .DayOfWeekMask is sum of 64 for Saturday, 32 for Friday, ... 1 for Sunday
For InxDCrnt = 0 To 6 ' Sunday to Saturday
If (.DayOfWeekMask And MaskCrnt) <> 0 Then
NumDaysInDayOfWeekMask = NumDaysInDayOfWeekMask + 1
End If
MaskCrnt = MaskCrnt + MaskCrnt ' 1 -> 2 -> 4 ... -> 64
Next
If NumDaysInDayOfWeekMask = 1 Then
' Simple one day per week mask
ReDim DateAddNumbers(0 To 0)
DateAddNumbers(0) = .Interval * 7
Else
' .Interval is number of weeks between events
' If .Interval is 1, need one value per NumDaysInDayOfWeekMask
' If .Interval is >1, need one value per NumDaysInDayOfWeekMask+1
ReDim DateAddNumbers(0 To NumDaysInDayOfWeekMask + IIf(.Interval = 1, 0, 1) - 1)
' If meetings are Tuesday and Thursday with the first meeting on a
' Thursday, the intervals are 5, 2 and then 0 or 7 or 14 and so on
' according to the number of weeks between meetings.
' If meetings are Tuesday and Thursday with the first meeting on a
' Tuesday, the intervals are 2, 5 and then 0 or 7 or 14 and so on
' according to the number of weeks between meetings.
' In either case, the intervals then repeat until DateCrnt is after
' the report period.
' Starting the check for a date being within report period from the
' pattern start date will cause a delay if the pattern start date
' was in the remote past. If this happens, the start date for the
' check may have to be reviewed.
' Return value is 1 to 7. Want 0 to 6 for array index
InxDStart = Weekday(.PatternStartDate) - 1
' End day of week is day before start day of week
InxDEnd = IIf(InxDStart = 1, 7, InxDStart - 1)
InxDCrnt = InxDStart
IntervalNext = 1
InxDAN = 0
Do While True
' Start check at day of week after start date of week.
' Cycle back to zero after checking sixth day of week
InxDCrnt = IIf(InxDCrnt = 6, 0, InxDCrnt + 1)
If (DayOfWeekMaskValues(InxDCrnt) And .DayOfWeekMask) <> 0 Then
' This day is within day-of-week mask
DateAddNumbers(InxDAN) = IntervalNext
InxDAN = InxDAN + 1
IntervalNext = 0
End If
IntervalNext = IntervalNext + 1
If InxDCrnt = InxDEnd Then
Exit Do
End If
Loop
DateAddNumbers(InxDAN) = IntervalNext
InxDAN = InxDAN + 1
If .Interval > 1 Then
DateAddNumbers(InxDAN) = (.Interval - 1) * 7
End If
End If
ElseIf .RecurrenceType = olRecursDaily Then
Debug.Assert False
DateAddInterval = "d"
' .Interval is the interval between occurrences in days
DateAddNumbers = VBA.Array(.Interval)
End If
OccurrenceInRange = False ' Assume no occurrences in range until find otherwise
DateCrnt = .PatternStartDate
InxDAN = LBound(DateAddNumbers)
Do While True
If DateCrnt >= DateReportStart And DateCrnt <= DateReportEnd Then
' This occurrence within report range
OccurrenceInRange = True
'Debug.Print " In range " & DateCrnt
ExceptionNoneForDateCrnt = True
For InxE = 1 To .Exceptions.Count
With .Exceptions.Item(InxE)
If DateValue(.OriginalDate) = DateCrnt Then
' Have exception for this occurence
ExceptionNoneForDateCrnt = False
If .Deleted Then
' Occurence deleted.
' Nothing to output.
Else
' Occurence amended
With .AppointmentItem
ExceptionAllDayEvent = .AllDayEvent
ExceptionDateStart = .Start
ExceptionDateEnd = .End
ExceptionSubject = .Subject
ExceptionLocation = Location
' I cannot change the categories for an exception
End With
AppointToReport.Add Array( _
CalcStartDateCrnt(ExceptionDateStart, DateCrnt, _
ExceptionAllDayEvent), _
CalcEndDateCrnt(ExceptionDateStart, ExceptionDateEnd, _
DateCrnt, ExceptionAllDayEvent), _
ExceptionSubject, ExceptionLocation, Categories)
End If
Exit For
End If
End With
Next
If ExceptionNoneForDateCrnt Then
' No exception for this occurrence
AppointToReport.Add Array( _
CalcStartDateCrnt(DateStart, DateCrnt, AllDayEvent), _
CalcEndDateCrnt(DateStart, DateEnd, DateCrnt, AllDayEvent), _
Subject, Location, Categories)
End If
ElseIf DateCrnt >= DateReportEnd Then
' This occurrence is after end of report range
'Debug.Print " After range " & DateCrnt
Exit Do
Else
' This occurrence is before report range
'Debug.Print " Before range " & DateCrnt
End If
' Prepare for next repeat of loop
DateCrnt = DateAdd(DateAddInterval, DateAddNumbers(InxDAN), DateCrnt)
InxDAN = InxDAN + 1
If InxDAN > UBound(DateAddNumbers) Then
InxDAN = LBound(DateAddNumbers)
End If
Loop
End If
'If OccurrenceInRange Then
' 'Debug.Assert False
' Debug.Print " StartEndDate " & DateStart & " - " & DateEnd & _
' " " & IIf(AllDayEvent, "All", "Part") & " day"
' Debug.Print " PatternStartEndDate " & .PatternStartDate & " - " & .PatternEndDate
' Debug.Print " DayOfMonth " & .DayOfMonth & " " & "MonthOfYear " & .MonthOfYear
' Debug.Print " DayOfWeekMask " & .DayOfWeekMask
' Debug.Print " Instance " & .Instance & " " & "Interval " & .Interval
' Debug.Print " NoEndDate " & .NoEndDate
' Debug.Print " Occurrences " & .Occurrences
' Debug.Print " RecurrenceType " & .RecurrenceType & " ";
' Select Case .RecurrenceType
' Case olRecursYearly
' Debug.Print "Yearly"
' Case olRecursYearNth
' Debug.Print "YearNth"
' Case olRecursMonthly
' Debug.Print "Monthly"
' Case olRecursMonthNth
' Debug.Print "MonthNth"
' Case olRecursWeekly
' Debug.Print "Weekly"
' Case olRecursDaily
' Debug.Print "Daily"
' End Select
' Debug.Print " StartEndTime " & .StartTime & " - " & .EndTime
'End If
End With ' RecurrPattern
Case olApptException
Debug.Assert False
' Exceptions are linked to their Master calendar entry.
' I do not believe they exist at calendar entries
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
Case Else
Debug.Print "Unrecognised (" & .RecurrenceState & ")"
Debug.Assert False
End Select
End With ' AppointCrnt
End If ' CalItemClass = olAppointment
Next InxFC
' Output appointments to worksheet "Appointments"
With Worksheets("Appointments")
.Cells.EntireRow.Delete
' Create headings
With .Cells(1, 1)
.Value = "Start"
.NumberFormat = "dmmmyy"
End With
.Cells(1, 2).NumberFormat = "h:mm"
With .Range(.Cells(1, 1), .Cells(1, 2))
.Merge
.HorizontalAlignment = xlCenter
End With
With .Cells(1, 3)
.Value = "End"
.NumberFormat = "dmmmyy"
End With
.Cells(1, 4).NumberFormat = "h:mm"
With .Range(.Cells(1, 3), .Cells(1, 4))
.Merge
.HorizontalAlignment = xlCenter
End With
.Cells(1, 5).Value = "Subject"
.Cells(1, 6).Value = "Location"
.Cells(1, 7).Value = "Categories"
.Range(.Cells(1, 1), .Cells(1, 7)).Font.Bold = True
RowCrnt = 2
' Output data rows
For InxATR = 1 To AppointToReport.Count
DateStart = AppointToReport(InxATR)(0)
DateEnd = AppointToReport(InxATR)(1)
Subject = AppointToReport(InxATR)(2)
Location = AppointToReport(InxATR)(3)
Categories = AppointToReport(InxATR)(4)
.Cells(RowCrnt, 1).Value = DateValue(DateStart)
.Cells(RowCrnt, 2).Value = TimeValue(DateStart)
.Cells(RowCrnt, 3).Value = DateValue(DateEnd)
If TimeValue(DateEnd) <> 0 Then
.Cells(RowCrnt, 4).Value = TimeValue(DateEnd)
Else
.Cells(RowCrnt, 4).Value = #11:59:00 PM#
End If
.Cells(RowCrnt, 5).Value = Subject
.Cells(RowCrnt, 6).Value = Location
.Cells(RowCrnt, 7).Value = Categories
RowCrnt = RowCrnt + 1
Next
.Columns.AutoFit
End With
End Sub
Function CalcStartDateCrnt(ByVal DateStart As Date, ByVal DateCrnt As Date, _
ByVal AllDayEvent As Boolean) As Date
' Calculate the start date/time for an occurrence of a recurring event
' DateStart The start date/time of the first occurrence of the event
' DateCrnt The date of the current occurrence
' AllDayEvent True for an all day event
If AllDayEvent Then
CalcStartDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), Day(DateCrnt))
Else
CalcStartDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), Day(DateCrnt)) + _
TimeSerial(Hour(DateStart), Minute(DateStart), Second(DateStart))
End If
End Function
Function CalcEndDateCrnt(ByVal DateStart As Date, ByVal DateEnd As Date, _
ByVal DateCrnt As Date, ByVal AllDayEvent As Boolean) As Date
' Calculate the end date/time for an occurrence of a recurring event
' DateStart The start date/time of the first occurrence of the event
' DateEnd The end date/time of the first occurrence of the event
' DateCrnt The date of the current occurrence
' AllDayEvent True for an all day event
If AllDayEvent Then
' Times not required
If DateAdd("d", 1, DateValue(DateStart)) = DateValue(DateEnd) Then
' Single day event
CalcEndDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), Day(DateCrnt))
Else
' Multi-day event
CalcEndDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), _
Day(DateCrnt) + Day(DateEnd) - Day(DateStart) - 1)
End If
Else
CalcEndDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), _
Day(DateCrnt) + Day(DateEnd) - Day(DateStart)) + _
TimeSerial(Hour(DateEnd), Minute(DateEnd), Second(DateEnd))
End If
End Function