Đếm email theo triển vọng theo ngày

Question

Tôi có mã sau để đếm số lượng email trong thư mục 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 

Tôi đang cố đếm số email trong thư mục này theo ngày để tôi kết thúc đếm mỗi ngày.

Answer 1

Bạn có thể thử nó với mã này:

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