Count Emails in Folder/Subfolder in Current Month

[hmltnangel]

OK, cross post - but no reply on Mr Excel. So I thought I would ask here.

I need some VBA to count the emails in a shared mailbox for the current month.

This code here, works well but shows things by month only, and the order of the months is out. Can someone please help change so it shows by month (in the correct order), and subfolder?

For Example

Subfolder
2019-12 - number of emails
2020-1 - number of emails

Subfolder 2
2019-11 - number of emails
2019-12 - number of emails
2020-1 - number of emails

etc etc

Sub HowManyEmails()

    Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
    Dim EmailCount As Integer
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")


        On Error Resume Next
        Set objFolder = Application.Session.PickFolder
        If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder."
        Exit Sub
        End If


    EmailCount = objFolder.Items.Count


    MsgBox "Number of emails in the folder: " & EmailCount, , "email count"


    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 ("SentOn")
    ' Determine date of each message:
    For Each myItem In myItems
        dateStr = GetDate(myItem.SentOn)
        If Not dict.Exists(dateStr) Then
            dict(dateStr) = 0
        End If
        dict(dateStr) = CLng(dict(dateStr)) + 1
    Next myItem


    ' Output counts per day:
    msg = ""
    For Each o In dict.Keys
        msg = msg & o & ": " & dict(o) & " items" & vbCrLf
    Next
    MsgBox msg


    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing
End Sub


Function GetDate(dt As Date) As String
    GetDate = Year(dt) & "-" & Month(dt) & "-"
End Function

[gmayor]

The following should give you the count of the selected folder and its sub-folders for the current month. If there are many sub-folders it could take a while to run.

Sub CountMail()
'Graham Mayor - https://www.gmayor.com - Last updated - 30 Aug 2020
Dim strCount As String
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Folder
Dim olNS As Outlook.NameSpace
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.PickFolder
    strCount = "Mesaages for " & Format(Date, "mmmm yyyy") & vbCr & vbCr
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        strCount = strCount & olFolder.Name & vbTab & ProcessFolder(olFolder) & vbCr
        ' Debug.Print olfolder.Name & vbTab & olfolder.items.Count
        For Each SubFolder In olFolder.folders
            cFolders.Add SubFolder
        Next SubFolder
    Loop
    MsgBox strCount
lbl_Exit:
    Set olFolder = Nothing
    Set SubFolder = Nothing
    Exit Sub
err_Handler:
    GoTo lbl_Exit
End Sub

Function ProcessFolder(olFldr As Folder) As Integer
'Graham Mayor - https://www.gmayor.com - Last updated - 31 Aug 2020
Dim olItem As Object
Dim dDate As Date
Dim i As Integer, j As Integer
    j = 0
    olFldr.items.Sort "[Received]", True
    For i = olFldr.items.Count To 1 Step -1
        Set olItem = olFldr.items(i)
        dDate = Left(olItem.ReceivedTime, 10)
        If Month(dDate) = Month(Date) And Year(dDate) = Year(Date) Then
            j = j + 1
        Else
            Exit For
        End If
        DoEvents
    Next i
    ProcessFolder = j
lbl_Exit:
    Set olItem = Nothing
    Exit Function
End Function