Count Emails in Folder/Subfolder in Current Month
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
Code:
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