Code to total minutes by category for specific date range

I've used the code below to total time by category for a specific day. I'd like to modify it to total the time by category for a specific date range. For example, I need a code prompt me for a date range, then to show me the time spent by category.

Sub TotalCategories()

Dim app As New Outlook.Application
Dim namespace As Outlook.namespace
Dim calendar As Outlook.Folder
Dim appt As Outlook.AppointmentItem
Dim apptList As Outlook.Items
Dim apptListFiltered As Outlook.Items
Dim explorer As Outlook.explorer
Dim view As Outlook.view
Dim calView As Outlook.CalendarView
Dim startDate As String
Dim endDate As String
Dim category As String
Dim duration As Integer
Dim outMsg As String

' Access appointment list
Set namespace = app.GetNamespace("MAPI")
Set calendar = namespace.GetDefaultFolder(olFolderCalendar)
Set apptList = calendar.Items

' Include recurring appointments and sort the list
apptList.IncludeRecurrences = True
apptList.Sort "[Start]"

' Get selected date
Set explorer = app.ActiveExplorer()
Set view = explorer.CurrentView()
Set calView = view
startDate = Format(calView.SelectedStartTime, "dd/MM/yyyy") & " 00:01"
endDate = Format(calView.SelectedEndTime, "dd/MM/yyyy") & " 11:59 PM"

' Filter the appointment list
strFilter = "[Start] >= '" & startDate & "'" & " AND [End] <= '" & endDate & "'"
Set apptListFiltered = apptList.Restrict(strFilter)

' Loop through the appointments and total for each category
Set catHours = CreateObject("Scripting.Dictionary")
For Each appt In apptListFiltered
    category = appt.Categories
    duration = appt.duration
    If catHours.Exists(category) Then
        catHours(category) = catHours(category) + duration
    Else
        catHours.Add category, duration
    End If
Next

' Loop through the categories
keyArray = catHours.Keys
For Each key In keyArray
    outMsg = outMsg & key & ": " & (catHours(key) / 60) & vbCrLf & vbCrLf
Next

' Display final message
MsgBox outMsg, , "Category Totals"

' Clean up objects
Set app = Nothing
Set namespace = Nothing
Set calendar = Nothing
Set appt = Nothing
Set apptList = Nothing
Set apptListFiltered = Nothing
Set explorer = Nothing
Set view = Nothing
Set calView = Nothing

End Sub

1 answer

  • answered 2022-01-19 22:14 Eugene Astafiev

    In your code you are using the date which is on the view in Outlook:

    Set view = explorer.CurrentView()
    Set calView = view
    startDate = Format(calView.SelectedStartTime, "dd/MM/yyyy") & " 00:01"
    endDate = Format(calView.SelectedEndTime, "dd/MM/yyyy") & " 11:59 PM"
    

    Instead, you are interested in getting these two dates from a prompt.

     Dim dte As String
     dte = InputBox("Please Enter Date: ", Default:=Format(Now, "dd/mm/yyyy"))
    

    So, you could use these dates in the code.

How many English words
do you know?
Test your English vocabulary size, and measure
how many words do you know
Online Test
Powered by Examplum