我想统计每个月共享邮箱/子文件夹中的电子邮件数。
此代码只显示一个文件夹的每个月的计数，并且月份的顺序是out。
如何按月份(按正确顺序(和子文件夹显示？
我想要的输出示例：
子文件夹
2019-12-电子邮件数量
2020-1-电子邮件数量
子文件夹2
2019-11-电子邮件数量
22019-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
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