VBA – Count emails on a date

Planning for support desks isn’t easy.  Support request volumes adjust with month-end, billing and payment cycles, holidays, etc.  Phone call volumes are usually pretty easy to find.  Emails — not always so easy.  That’s why there’s this little script.  Navigate in Outlook to the folder you want to count (maybe the inbox or archives of a shared mailbox) enter the date (be careful that you don’t use any leading zeros) and get the total number of emails in that folder for the same day last week, last month, or maybe for the same holiday last year.

Sub EmailsOnDate()

    Dim objOutlook As Object
    Dim objMAPI As Object
    Dim objFolder As MAPIFolder
    Dim oDate As String
     
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMAPI = objOutlook.GetNamespace("MAPI")
    
    oDate = InputBox("What date would you like counted? " + vbCrLf + "format: YYYY-M-D")
    
        On Error Resume Next
        Set objFolder = Application.ActiveExplorer.CurrentFolder
        If Err.Number <> 0 Then
        Err.Clear
        MsgBox "Invalid folder.  Please select the folder you want counted and try again."
        Exit Sub
        End If
    
    Dim ssitem As MailItem
    Dim dateStr As String
    Dim myItems As Outlook.Items
    Dim dict As Object
    Dim msg As String
    Set dict = CreateObject("Scripting.Dictionary")
    Set myItems = objFolder.Items
    myItems.SetColumns ("ReceivedTime")
    
    ' match dates
    For Each myItem In myItems
        dateStr = GetDate(myItem.ReceivedTime)
        If dateStr = oDate Then
            If Not dict.Exists(dateStr) Then
                dict(dateStr) = 0
            End If
            dict(dateStr) = CLng(dict(dateStr)) + 1
        End If
    Next myItem
    
    ' daily count
    msg = ""
    For Each o In dict.Keys
        msg = msg & o & ": " & dict(o) & " items" & vbCrLf
    Next
    If msg <> "" Then
    MsgBox msg
    Else: MsgBox ("No items found")
    End If
    
    Set objFolder = Nothing
    Set objMAPI = Nothing
    Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As String
    GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function