按子文件夹和发送月份计算共享邮箱中的电子邮件

Question

我想统计每个月共享邮箱/子文件夹中的电子邮件。

此代码仅显示一个文件夹的每个月的计数，并且月份的顺序已超出。

如何按月（按正确顺序）和子文件夹显示？

我想要的输出示例：

子文件夹
2019-12 - 电子邮件数量
2020-1 - 电子邮件数量

子文件夹 2
2019-11 - 电子邮件数量
2019-12 - 电子邮件数量
2020-1 - 电子邮件数量

等等

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

Answer 1

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Private Sub HowManyEmails_With_Subfolders()
    
    Dim objFolder As Folder
    
    Set objFolder = Session.PickFolder

    If objFolder Is Nothing Then
        Exit Sub
    End If
    
    processFolderSorted objFolder

End Sub

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

Private Sub processFolderSorted(ByVal objFolder As Folder)

' https://stackoverflow.com/questions/2272361/can-i-iterate-through-all-outlook-emails-in-a-folder-including-sub-folders

    Dim EmailCount As Long
    
    Dim dateStr As String
    
    Dim myItem As Object
    Dim myItems As items
    
    Dim dict As Object
    Dim o
    
    Dim msgCount As String
    Dim msg As String
    
    Dim oFolder As Folder
    
    Debug.Print "objFolder: " & objFolder
    
    EmailCount = objFolder.items.count
    'Debug.Print "EmailCount: " & EmailCount
    
    If EmailCount > 0 Then
    
        msgCount = "Number of emails in " & objFolder & ": " & EmailCount & vbCr
        'Debug.Print msgCount
        
        Set dict = CreateObject("Scripting.Dictionary")
        
        Set myItems = objFolder.items
        
        myItems.Sort "[SentOn]", False
        
        myItems.SetColumns ("SentOn")
            
        ' Determine date of each message
        For Each myItem In myItems
                
            ' Some item types / item classes
            '  will not have an expected mailitem property
            If myItem.Class = olMail Then
            
                dateStr = GetDate(myItem.SentOn)
            
                If Not dict.Exists(dateStr) Then
                    dict(dateStr) = 0
                End If
                
                dict(dateStr) = CLng(dict(dateStr)) + 1
                
            Else
            
                Debug.Print "item bypassed"
            
            End If
            
        Next
    
        ' Output counts per day:
        For Each o In dict.Keys
            msg = msg & o & ": " & dict(o) & " items" & vbCrLf
        Next
        
        Debug.Print msgCount & msg
        'MsgBox msgCount & msg
    
        Set dict = Nothing
        
    End If
    
    If (objFolder.folders.count > 0) Then
        For Each oFolder In objFolder.folders
            processFolderSorted oFolder
        Next
    End If
        
End Sub