Outlook VBA e-mail count per day

[gmayor]

OK to process sub folders you will need to add them to a collection e.g.

Option Explicit

Sub CountEmailsPerDay()
Dim cFolders As Collection, cResults As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Folder
Dim olNS As Outlook.NameSpace
Dim i As Long
Dim sList As String, sDate As String
sDate = InputBox("Type the date for count (format YYYY-m-d")
Set cFolders = New Collection
Set cResults = New Collection
Set olNS = GetNamespace("MAPI")
cFolders.Add olNS.PickFolder
MsgBox "This could take a while to process!"
Do While cFolders.Count > 0
    Set olFolder = cFolders(1)
    cFolders.Remove 1
    cResults.Add ProcessFolder(olFolder, sDate)
    For Each SubFolder In olFolder.folders
         cFolders.Add SubFolder
    Next SubFolder
    DoEvents
Loop
For i = 1 To cResults.Count
    sList = sList & cResults(i)
    If i < cResults.Count Then
        sList = sList & vbCr
        DoEvents
    End If
Next i
MsgBox "Messages received on " & sDate & vbCr & vbCr & sList
lbl_Exit:
Set olNS = Nothing
Set olFolder = Nothing
Set SubFolder = Nothing
Set cFolders = Nothing
Set cResults = Nothing
Exit Sub
err_Handler:
    GoTo lbl_Exit
End Sub

Private Function ProcessFolder(iFolder As Folder, sDate As String) As String
Dim i As Long, j As Long
Dim olItem As Outlook.MailItem
Dim sDateStr As String
iFolder.items.SetColumns ("ReceivedTime")
j = 0
For i = 1 To iFolder.items.Count
    Set olItem = iFolder.items(i)
    sDateStr = GetDate(olItem.ReceivedTime)
    If sDateStr = sDate Then
        j = j + 1
     End If
    DoEvents
Next i
ProcessFolder = iFolder.Name & Chr(58) & Chr(32) & j & " items"
lbl_Exit:
Set olItem = Nothing
Exit Function
End Function


Private Function GetDate(dDate As Date) As String
GetDate = Year(dDate) & "-" & Month(dDate) & "-" & Day(dDate)
lbl_Exit:
Exit Function
End Function