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