Liczenie wiadomości e-mail w programie Outlook według daty

Question

Mam następujący kod, aby policzyć liczbę wiadomości e-mail w folderze programu Outlook.

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

    On Error Resume Next  
    Set objFolder = objnSpace.Folders("Personal Folders").Folders("Inbox").Folders("report's").Folders("Customer")  
    If Err.Number <> 0 Then  
    Err.Clear 
    MsgBox "No such folder."  
    Exit Sub  
    End If 

EmailCount = objFolder.Items.Count  
Set objFolder = Nothing  
Set objnSpace = Nothing  
Set objOutlook = Nothing 

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

Próbuję policzyć wiadomości e-mail w tym folderze według daty, więc kończę z liczbą na każdy dzień.

Answer 1

Można spróbować z tym kodem:

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 = objnSpace.Folders("Personal Folders").Folders("Inbox").Folders("report's").Folders("Customer") 
     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) & "-" & Day(dt) 
End Function