Updated on 3/1/2024
Should you be using the Outlook calendar, this script extracts useful information about your appointments, which you can analyze to gain insight on how you spent your time by project, time period, the persons you interact most, etc.
Specifically, it scans your calendar entries and assembles the list of all your appointments.
By the way, there is a relevant article that extracts information about your Outlook mails.
For each appointment, it will accumulate a variety of properties, such as start, end, duration, subject, category, attendees, etc. There’s the full list of all properties:
AllDayEvent, AutoResolvedWinner, BillingInformation, BusyStatus, Categories, Class, Companies, ConversationIndex, ConversationTopic, CreationTime, DownloadState, Duration, End, EndInEndTimeZone, EndTimeZone, EndUTC, EntryID, ForceUpdateToAllAttendees, FormDescription, GlobalAppointmentID, Importance, InternetCodepage, IsConflict, IsRecurring, LastModificationTime, Location, MarkForDownload, MeetingStatus, MeetingWorkspaceURL, MessageClass, Mileage, NoAging, OptionalAttendees, Organizer, OutlookInternalVersion, OutlookVersion, RecurrenceState, ReminderMinutesBeforeStart, ReminderOverrideDefault, ReminderPlaySound, ReminderSet, ReminderSoundFile, ReplyTime, RequiredAttendees, Resources, ResponseRequested, ResponseStatus, Saved, Sensitivity, Size, Start, StartTimeZone, StartUTC, Subject, UnRead
The information for the appointments is stored in a Comma Separated File, ready to be fed to your Excel, or favorite data analytics tool (mine was Power BI, but now I reverted back to MS Access). A sample is shown below, where I have left visible the most important properties.
You can press Alt-F11 in Outlook to open the VBA and Insert | Module for a clean editor window. Then copy and paste the code below into an empty Outlook module. Place your cursor anywhere into the CalendarAppointments subroutine and press F5 to run it.
Option Explicit
' CalendarAppointments() gets all appointments with their detailed field properties
' from Outlook Calendar and saves them in a CSV file
' Code originates from http://www.GregThatcher.com
' Edited by I Gaviotis, igaviotis.wordpress.com
' Version 2023-07-06 added explanatory comments on use
' Version 2024-01-03 added explanatory comments and edited for easy read
' Paste the VBA code in an Outlook module (to open new module, Alt-F11).
' Run CalendarAppointments() by pressing F5 on its body.
' Outputs CSV file, saved on Desktop to find easily.
' Observe results in Excel.
Public Sub CalendarAppointments()
On Error GoTo ErrorHandler
Dim objSession As Outlook.NameSpace
Dim objAppointmentsFolder As Outlook.Folder
Set objSession = Application.Session
Set objAppointmentsFolder = objSession.GetDefaultFolder(olFolderCalendar)
Dim strOutputFilename As String, outFile As Integer
strOutputFilename = "CalendarAppointments.csv" 'creates file in Desktop folder
outFile = FreeFile
Open strOutputFilename For Output As #outFile
Debug.Print "CalendarAppointments Start " & Now
Debug.Print "Appointments will be saved in " & strOutputFilename & ".."
Dim arrFields As Variant
arrFields = Array( _
"AllDayEvent", "AutoResolvedWinner", "BillingInformation", "BusyStatus", _
"Categories", "Class", "Companies", "ConversationIndex", "ConversationTopic", _
"CreationTime", "DownloadState", "Duration", "End", "EndInEndTimeZone", _
"EndTimeZone", "EndUTC", "EntryID", "ForceUpdateToAllAttendees", _
"FormDescription", "GlobalAppointmentID", "Importance", "InternetCodepage", _
"IsConflict", "IsRecurring", "LastModificationTime", "Location", _
"MarkForDownload", "MeetingStatus", "MeetingWorkspaceURL", "MessageClass", _
"Mileage", "NoAging", "OptionalAttendees", "Organizer", "OutlookInternalVersion", _
"OutlookVersion", "RecurrenceState", "ReminderMinutesBeforeStart", _
"ReminderOverrideDefault", "ReminderPlaySound", "ReminderSet", _
"ReminderSoundFile", "ReplyTime", "RequiredAttendees", "Resources", _
"ResponseRequested", "ResponseStatus", "Saved", "Sensitivity", "Size", _
"Start", "StartTimeZone", "StartUTC", "Subject", "UnRead")
Dim strLine As String, i As Integer
strLine = ""
For i = LBound(arrFields) To UBound(arrFields) 'traverse array with appointments fields
strLine = strLine & arrFields(i) & ", " 'first line of CSV contains field names
Next i
strLine = Left(strLine, Len(strLine) - 2)
Print #outFile, strLine ' CSV header
Dim objItem As Object
For Each objItem In objAppointmentsFolder.Items ' for each Outlook item
If (objItem.Class = olAppointment) Then ' if it is an appointment
strLine = ""
With objItem
For i = LBound(arrFields) To UBound(arrFields) 'assemble all fields of one appointment
strLine = strLine & Sanitize(CallByName(objItem, arrFields(i), VbGet)) & ", "
Next i
End With
strLine = Left(strLine, Len(strLine) - 2)
Print #outFile, strLine
End If
Next objItem
Close #outFile
Debug.Print "CalendarAppointments End " & Now
Exiting:
Set objSession = Nothing
Set objAppointmentsFolder = Nothing
Exit Sub
ErrorHandler:
Debug.Print Err.Number, Err.Description
Resume Exiting
End Sub
Function Sanitize(ByVal str As String) As String
' get rid of single & double quotes, commas, carriage returns and semicolons, to maintain intact the CSV structure
Sanitize = Replace(Replace(Replace(Replace(Replace(Replace(str, _
"'", " "), """", " "), ",", ""), vbCrLf, " "), vbCr, " "), ";", " ")
End Function
On your Desktop you’ll find the CalendarAppointments.csv file that you can readily open with Excel to purview the entries fields and filter / sort as needed.
For the more inclined, I would suggest to import the CSV file into MS Access (First Row Contains Field Names; if truncation occurs for RequiredAttendees or OptionalAttendees, change Short Text -> Long Text). Then query extensively, like:
SELECT Year([Start]) AS StartYear, Month([Start]) AS StartMonth,
Count(EntryID) AS AppointmentCount
FROM CalendarAppointments
GROUP BY Year([Start]), Month([Start])
ORDER BY Count(EntryID) DESC;
TRANSFORM Sum(Duration/60) AS DurationInHours
SELECT Month(Start) AS StartMonth
FROM CalendarAppointments
WHERE AllDayEvent="False" AND BusyStatus=2
GROUP BY Month(Start)
PIVOT Year(Start);
Note: in the query above I included only accepted appointments (BusyStatus=2); I do not follow those that I mark as tentative and Outlook deletes those declined (in newer version that changes – at last). I also excluded full day events (usually holidays, etc.); each would contribute 24 hours to duration. Originally, duration is in minutes, so dividing by 60 gets it in hours. I pivoted by year and totals are actually average monthly durations for each year, so 2023 was busier than 2022.
igaviotis 