Reputation: 93
Weekly / Monthly Time Reports in Outlook for several categories
I want to extract the time spent (weekly and monthly) in Outlook Calendar for different categories to extract reports.
I found this code with which I tried to play a bit with the goal to summarize the information for the whole calendar in an excel worksheet:
Sub ExportTimeSpentOnAppointmentsInEachColorCategory()
Dim objDictionary As Object
Dim objAppointments As Outlook.Items
Dim objAppointment As Outlook.AppointmentItem
Dim strCategory As String
Dim arrCategory As Variant
Dim varCategory As Variant
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Dim arrKey As Variant
Dim arrItem As Variant
Dim i As Long
Dim nLastRow As Integer
Set objDictionary = CreateObject("Scripting.Dictionary")
Set objAppointments = Application.Session.PickFolder.Items
For Each objAppointment In objAppointments
arrCategory = Split(objAppointment.Categories, ",")
For Each varCategory In arrCategory
strCategory = Trim(varCategory)
If objDictionary.Exists(strCategory) Then
objDictionary.Item(strCategory) = objDictionary.Item(strCategory) + objAppointment.Duration
Else
objDictionary.Add strCategory, objAppointment.Duration
End If
Next
Next
'Create a new Excel workbook
Set objExcelApp = CreateObject("Excel.Application")
Set objExcelWorkbook = objExcelApp.Workbooks.Add
Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
objExcelApp.Visible = True
objExcelWorkbook.Activate
With objExcelWorksheet
.Cells(1, 1) = "Color Category"
.Cells(1, 1).Font.Bold = True
.Cells(1, 1).Font.Size = 14
.Cells(1, 2) = "Total Time (min)"
.Cells(1, 2).Font.Bold = True
.Cells(1, 2).Font.Size = 14
End With
arrKey = objDictionary.Keys
arrItem = objDictionary.Items
For i = LBound(arrKey) To UBound(arrKey)
nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.count).End(xlUp).Row + 1
objExcelWorksheet.Cells(nLastRow, 1) = arrKey(i)
objExcelWorksheet.Cells(nLastRow, 2) = arrItem(i)
Next
objExcelWorksheet.Columns("A:B").AutoFit
End Sub
How can I modify this code to generate this report for a given week or month (e.g. January 2020).
Upvotes: 1
Views: 1380
Answers (2)
Reputation: 12413
My total answer exceeds StackOverflow's limit of 30,000 characters so I have split the answer into two
Part 2
On more detailed checking, I found my second macro did not contain a bug; it was unfinished. My guess is I developed it far enough to discover what I needed to know and then abandoned it.
I have now finished that macro. It probably contains everything you need for the first issue on my list: How to find the calendar items for the period I wish to analyse?
Finding the calendar items you wish to analyse is trickier than you might expect. A one-off meeting will result in a single AppointmentItem in your calendar. That AppointmentItem will contain everything you need to know about the meeting. In particular, it contains properties Start and End which will allow a simple check against the report range. It is recurring appointments that are tricky.
Suppose I have regular team meetings on Tuesday and Thursday. I will go to my calendar and create an appointment for Thursday, 2 January 2020. I will enter the title, location, categories. I will then click [Recurrence]. I will click (Weekly) if it is not already selected as the Recurrence pattern. Thursday will be ticked. I will tick Tuesday. I will change the End date to Thursday, 31 December 2020. My calendar now shows appointments for every Tuesday and Thursday for the entire year. I have holidays booked for June, so I will delete the relevant entries. Later, I receive a message saying a particular meeting is to be half-an-hour later than normal and in a different meeting room. I will change the details for relevant day.
If a VBA macro looks at my calendar, it will find a single Master appointment for 2 January 2020. A Master appointment is one that recurs. The macro uses GetRecurrencePattern() to get the details of how the appointment recurs. The recurrence pattern also records all the exceptions.
The 100 or so entries on my calendar, have been generated from one AppointmentItem. To decide which of these entries are within the report period, my macro generates an array containing 5 and 2. It starts with Thursday 2 January 2020, then steps forward 5 days then 2 days then 5 days then 2 days then 5 days and so on until it is past the report period. The 5-day step takes it from Thursday to Tuesday. The 2-day step takes it from Tuesday to Thursday. The macro checks every date against the report period. If the date is within the report period, the macro checks for an exception. If there is no exception for the date, the macro adds a regular entry to the collection AppointToReport. An exception can be a delete of an occurrence or a change to an occurrence. For a delete, the macro does not add to the collection. For a change, it adds an entry based on the exception.
If that last paragraph was confusing, you will have to create some test appointments and step through the macro and study what it does.
I said at the beginning that I start with the object model for an AppointmentItem. This is a useful start, but it does not say which properties are used with which recurrence patterns. To discover that I use Watch. You will find [Watch Window] under [View] and [Add Watch] under [Debug]. I added the variables holding the AppointmentItem and the RecurrencePattern. This allowed me to understand how each property was used under different circumstances.
The macro below is an Excel macro. When you want to move data from Outlook to Excel, it can be difficult to decide whether to write the macro within Outlook or Excel since the code is very similar with both approaches. Outlook has a robust security system that does not like outside macros accessing its database, so the user must give permission at least once every 10 minutes. It does not worry about an Excel macro reading appointments, so that is not a consideration for you. For me, the biggest considerations are: (1) I find the Excel VBA development environment slightly easier than the Outlook development environment and (2) it is easier to share Excel macros with colleagues than Outlook macros.
If you really want an Outlook macro, you will have to recode the start of my macro.
I said earlier, the macro adds an entry to a collection for every event within the report range. When it has checked the entire calendar, it outputs the contents of that collection to a worksheet. For my test data, output is
The entries in the collection contain Start, End, Subject, Location and Categories. You can easily add more values if necessary. Note that the events are listed in the order added to the calendar. I added some appointments with categories first then appointments that used as many recurrence options as I thought I ought to test. If I understand correctly, you want to sum the total time per category so the sequence should not matter. You should test the macro will all AppointmentItem options you use.
I have left all my testing code within the macro but have commented it out. You can remove the quotes if you want to restore the output. I place Debug.Assert False at the top of every path through my code. When that path is executed, I comment the Debug.Assert False out. If you find a Debug.Assert False without a quote, it means the code below it has not been tested.
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
Upvotes: 1
Reputation: 12413
Part 1
If you do not know where to start with a problem, searching for blocks of code that might contain relevant code can be a good start. But you need to mine that code for useful nuggets. Simply trying to adapt that code to your problem is not going to work nor is asking someone else to adapt it.
What do you need to know? My initial list is:
- How to find the calendar items for the period I wish to analyse?
- How do I sort those calendar items by category?
- How do I create a new Excel workbook or how do I update an existing workbook?
- How do I arrange the information within the workbook in a useful manner?
This is not a complete list. For example: how does the user specify the required date range? I am not going to worry about such issues while I investigate the more difficult issues. Your code relates to need 2 so I will concentrate on need 1.
If there are any good Outlook VBA tutorials on calendars, I have not found them. Everything I know is the result of experimentation.
I created some appointments in the future, so they did not get confused with my real appointments. I used all the options within Create Appointment that were of interest to me. I created single appointments for different periods within same day, all day events, appointments that started on one day and ended on another. I created recurrent entries for every available period, for a fixed number of occurrences, until a given date or for ever. I then altered or deleted single occurrences.
I started with the object model for appointment items. I wrote a routine that looped down my appointment items outputting the properties that looked interesting. I learnt about the different type of appointment item and which properties went with which type. The routines below are the result of my experimentation.
The first thing I learnt was that my calendar was not where I expected it to be. This routine helps with that problem:
Sub CalendarDtls()
Dim InxFldrCrnt As Long
Dim InxStoreCrnt As Long
With Application.Session
Debug.Print "Store containing default calendar: " & .GetDefaultFolder(olFolderCalendar).Parent.Name
Debug.Print "Name of default calendar: " & .GetDefaultFolder(olFolderCalendar).Name
Debug.Print "Items in default calendar: " & .GetDefaultFolder(olFolderCalendar).Items.Count
For InxStoreCrnt = 1 To .Folders.Count
With .Folders(InxStoreCrnt)
For InxFldrCrnt = 1 To .Folders.Count
If LCase(Left$(.Folders(InxFldrCrnt).Name, 8)) = "calendar" Then
Debug.Print .Name & "\" & .Folders(InxFldrCrnt).Name & " Items: " & _
.Folders(InxFldrCrnt).Items.Count
Exit For
End If
Next
End With
Next
End With
End Sub
The above is an Outlook macro that displays details of the default calendar and of every calendar it can find.
When I started writing Outlook macros, I soon learnt how quickly the number of macros can grow and how difficult it can be to find the macro you want to look at today. I have lots of modules with meaningful names. My calendar experiments are in module ModCalendar. (Use F4 to access the Properties Window to rename modules.) I have no operational code in ModCalendar; operational code is held in modules with names like ModTaskName. I suggest you do something similar and place the above macro and the next one in a module named ModCalendar or something similar. Do not forget to include Option Explicit as the first statement.
Now consider this macro:
Sub DspCalendarItems()
' Create programmer-friendly list of items in selected calendar
' in desktop file Appointments.txt.
'Developed as aid to understanding Outlook calendars.
Dim ItemCrnt As Object
Dim ItemCrntClass As Long
Dim FileOut As Object
Dim FolderSrc As MAPIFolder
Dim Fso As FileSystemObject
Dim Path As String
Dim RecurrPattCrnt As RecurrencePattern
Path = CreateObject("WScript.Shell").specialfolders("Desktop")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set FileOut = Fso.CreateTextFile(Path & "\Appointments.txt", True)
With Application.Session
'Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
Set FolderSrc = .Folders("Outlook Data File").Folders("Calendar")
FileOut.WriteLine ("Number of items: " & FolderSrc.Items.Count)
For Each ItemCrnt In FolderSrc.Items
With ItemCrnt
' Occasionally I get syncronisation
' errors. This code avoids them.
ItemCrntClass = 0
On Error Resume Next
ItemCrntClass = .Class
On Error GoTo 0
' I have never found anything but appointments in
' Calendar but test just in case
If ItemCrntClass = olAppointment Then
Select Case .RecurrenceState
Case olApptException
FileOut.WriteLine ("Recurrence state is Exception")
If .AllDayEvent Then
FileOut.WriteLine ("All day " & Format(.Start, "ddd d mmm yy"))
Debug.Assert False
ElseIf Day(.Start) = Day(.End) Then
' Appointment starts and finishes on same day
If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
' Different start and end times on same day
FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
Debug.Assert False
Else
' Start and end time the same
Debug.Assert False
FileOut.Write ("At " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
End If
Else
' Different start and end dates.
FileOut.Write ("From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
End If
Debug.Assert False
Case olApptMaster
Set RecurrPattCrnt = .GetRecurrencePattern
Debug.Assert Year(RecurrPattCrnt.PatternStartDate) = Year(.Start)
Debug.Assert Month(RecurrPattCrnt.PatternStartDate) = Month(.Start)
Debug.Assert Day(RecurrPattCrnt.PatternStartDate) = Day(.Start)
If .AllDayEvent Then
FileOut.Write ("All day ")
ElseIf Day(.Start) = Day(.End) Then
'Debug.Assert False
' Appointment starts and finishes on same day
If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
' Different start and end times on same day
FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
Format(.End, "hh:mm") & " ")
'Debug.Assert False
Else
' Start and end time the same
FileOut.Write ("At " & Format(.Start, "hh:mm") & " ")
Debug.Assert False
End If
ElseIf DateDiff("d", .Start, .End) = 1 And Format(.Start, "hh:mm") = "00:00" And _
Format(.End, "hh:mm") = "00:00" Then
FileOut.Write ("All day ")
'Debug.Assert False
Else
' Have not thought repeating multi-day appointments through
Debug.Assert False
FileOut.Write ("XXX From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
End If
Select Case RecurrPattCrnt.RecurrenceType
Case olRecursDaily
'Debug.Assert False
FileOut.Write ("daily")
Case olRecursMonthly
Debug.Assert False
FileOut.Write ("monthly")
Case olRecursMonthNth
Debug.Assert False
FileOut.Write ("nth monthly")
Case olRecursWeekly
'Debug.Assert False
FileOut.Write ("weekly")
Case olRecursYearly
'Debug.Assert False
FileOut.Write ("yearly")
End Select ' RecurrPattCrnt.RecurrenceType
FileOut.Write (" from " & Format(RecurrPattCrnt.PatternStartDate, "ddd d mmm yy"))
If Year(RecurrPattCrnt.PatternEndDate) = 4500 Then
' For ever
'Debug.Assert False
Else
FileOut.Write (" to " & Format(RecurrPattCrnt.PatternEndDate, "ddd d mmm yy"))
'Debug.Assert False
End If
Case olApptNotRecurring
If .AllDayEvent Then
FileOut.Write ("All day " & Format(.Start, "ddd d mmm yy"))
'Debug.Assert False
ElseIf Day(.Start) = Day(.End) Then
' Appointment starts and finishes on same day
If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
' Different start and end times on same day
FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
'Debug.Assert False
Else
' Start and end time the same
FileOut.Write ("At " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
'Debug.Assert False
End If
Else
' Different start and end dates.
FileOut.Write ("From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
'Debug.Assert False
End If
Case olApptOccurrence
FileOut.WriteLine ("Occurrence")
Debug.Assert False
Case Else
Debug.Print ("Unknown recurrence state " & .RecurrenceState)
Debug.Assert False
FileOut.WriteLine ("Unknown recurrence state " & .RecurrenceState)
End Select ' .RecurrenceState
If .Subject <> "" Then
FileOut.Write (" " & .Subject)
Else
FileOut.Write (" ""No subject""")
End If
If .Location <> "" Then
FileOut.Write (" at " & .Location)
Else
FileOut.Write (" at undefined location")
End If
FileOut.WriteLine ("")
If .Body <> "" Then
FileOut.WriteLine (" Body: " & .Body)
End If
End If ' ItemCrntClass = olAppointment
End With ' ItemCrnt
Next ItemCrnt
End With ' Application.Session
FileOut.Close
End Sub
Near the top of the above macro, you will find:
'Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
Set FolderSrc = .Folders("Outlook Data File").Folders("Calendar")
If your appointments are in the default calendar, remove the quote from the first line and add one to the second. If your appointments are NOT in the default calendar, CalendarDtls() will have output something like:
Store containing default calendar: [email protected]
Name of default calendar: Calendar (This computer only)
Items in default calendar: 0
[email protected] @virginmedia.com\Calendar (This computer only) Items: 0
Outlook Data File\Calendar Items: 180
Find the row with a non-zero value for Items and copy the store name (Outlook Data File for me) and the folder name (Calendar for me) to the second line.
Run this macro and study the output. Where does it get the values it displays? Most appointment items have the same properties, but those properties will not have sensible values for inappropriate items. How has the macro decided what properties to display and what not to display? Add display of categories. I was not interested in categories so the macro does not display them.
This macro is basic. It does not touch complicated issues like exceptions. I believe it will be a good start of understanding how to identify the appointments that fall within the report period.
I have discovered a bug in the next macro I wish to share. I will add this macro when I have fixed the bug.
Upvotes: 1
Related Questions
- Count / sum-up weekly work time by calendar category (MS Outlook)
- Assign found value, from a range, to variable
- Script to total hours by calendar category in Outlook
- Counting emails in outlook by date
- Send one report to each manager using VBA and Outlook
- Using VBA in Outlook to gather statistics on received emails
- Create macro in Outlook to extract data from reports
- Email Count Based on Category
- Integrating Access and Outlook with VBA for regular reporting
- Print "report" for meeting/appointment with Outlook Macro