如何统计未读电子邮件？

Question

我在outlook中使用以下vba代码来计算文件夹和子文件夹中的所有电子邮件。但我想编辑我的代码，以便它只计算未读的电子邮件。

有没有办法可以做到这一点，如果是这样，有人可以告诉我怎么做？

Sub HowManyEmails()

    Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
    Dim objFolder2 As MAPIFolder
    Dim objFolder3 As MAPIFolder
    Dim objFolder4 As MAPIFolder
    Dim objFolder5 As MAPIFolder
    Dim objFolder6 As MAPIFolder
    Dim objFolder7 As MAPIFolder
    Dim objFolder8 As MAPIFolder
    Dim objFolder9 As MAPIFolder
    Dim objFolder10 As MAPIFolder
    Dim objFolder11 As MAPIFolder
    Dim objFolder12 As MAPIFolder
    Dim objFolder13 As MAPIFolder
    Dim objFolder14 As MAPIFolder
    Dim EmailCount As Integer
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")

    On Error Resume Next

    Set objFolder = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("3PL & HAULAGE")
    Set objFolder2 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("ACCOMODATION")
    Set objFolder3 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("CORE FLEET & EQUIPMENT")
    Set objFolder4 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("LUBRICANTS & OILS")
    Set objFolder5 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("MARKETING")
    Set objFolder6 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("PLANT EQUIPMENT & TOOLS")
    Set objFolder7 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("PROPERTY & REFURBISHMENT")
    Set objFolder8 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("SECURITY & SYSTEMS")
    Set objFolder9 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("SERVICING & REPAIRS")
    Set objFolder10 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("STATIONARY")
    Set objFolder11 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("TESTING & CALIBRATING")
    Set objFolder12 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("UTILITIES: GAS, FUEL, ELECTRICAL (ENERGY)")
    Set objFolder13 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("X-HIRE CRANE HIRE")
    Set objFolder14 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("X-HIRE PLANT EQUIPMENT")


    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder."
        Exit Sub
    End If

    EmailCount = objFolder.Items.Count
    EmailCount2 = objFolder2.Items.Count
    EmailCount3 = objFolder3.Items.Count
    EmailCount4 = objFolder4.Items.Count
    EmailCount5 = objFolder5.Items.Count
    EmailCount6 = objFolder6.Items.Count
    EmailCount7 = objFolder7.Items.Count
    EmailCount8 = objFolder8.Items.Count
    EmailCount9 = objFolder9.Items.Count
    EmailCount10 = objFolder10.Items.Count
    EmailCount11 = objFolder11.Items.Count
    EmailCount12 = objFolder12.Items.Count
    EmailCount13 = objFolder13.Items.Count
    EmailCount14 = objFolder14.Items.Count

    MsgBox "New Suppliers & New Business Report Sent"

    TempFilePath = "\\UKSH000-File06\Purchasing\New_Supplier_Set_Ups_&_Audits\assets\"

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "<p style='color:#000;font-family:calibri;font-size:16'>Dear Jason," & vbNewLine & vbNewLine & _
              "<br><br>" & "This is your weekly report, for " & "<b>" & "New Suppliers & New Business Introductions" & "</b>" & ", sent to you from NewSuppliers." & vbNewLine & _
              "<br>" & "Please see a breakdown of different types of suppliers and new business below:" & vbNewLine & vbNewLine & _
              "<br><br><br>" & "3PL & HAULAGE SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount & "</b></font>" & vbNewLine & _
              "<br>" & "ACCOMODATION SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount2 & "</b></font>" & vbNewLine & _
              "<br>" & "CORE FLEET & EQUIPMENT SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount3 & "</b></font>" & vbNewLine & _
              "<br>" & "LUBRICANT & OILS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount4 & "</b></font>" & vbNewLine & _
              "<br>" & "MARKETING SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount5 & "</b></font>" & vbNewLine & _
              "<br>" & "PLANT EQUIPMENT & TOOLS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount6 & "</b></font>" & vbNewLine & _
              "<br>" & "PROPERTY & REFURBISHMENT SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount7 & "</b></font>" & vbNewLine & _
              "<br>" & "SECURITY & SYSTEMS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount8 & "</b></font>" & vbNewLine & _
              "<br>" & "SERVICING & REPAIRS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount9 & "</b></font>" & vbNewLine & _
              "<br>" & "STATIONARY SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount10 & "</b></font>" & vbNewLine & _
              "<br>" & "TESTING & CALIBRATING SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount11 & "</b></font>" & vbNewLine & _
              "<br>" & "UTILITIES & ENERGY SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount12 & "</b></font>" & vbNewLine & _
              "<br>" & "X-HIRE CRANE SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount13 & "</b></font>" & vbNewLine & _
              "<br>" & "X-HIRE PLANT SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount14 & "</b></font>" & vbNewLine & _
              "<br><br><br>" & "If you have any queries please reply to this email, NewSuppliers@Hewden.co.uk." & vbNewLine & vbNewLine & _
              "<br><br>" & "Kind Regards," & "</font></p>" & vbNewLine & _
              "<p style='color:#000;font-family:calibri;font-size:18'><b>Automated Purchasing Email</font></p></b>" & vbNewLine & _
              "<br><br><img src='cid:cover.jpg'" & "width='800' height='64'><br>" & vbNewLine & _
              "<img src='cid:subs.jpg'" & "width='274' height='51'>"



    With OutMail
        .SentOnBehalfOfName = "newsuppliers@hewden.co.uk"
        .To = "mark.o'brien@hewden.co.uk"
        .CC = ""
        .BCC = ""
        .Subject = "New Suppliers & New Business Introduction - Weekly Report"
        .HtmlBody = strbody
        .Attachments.Add TempFilePath & "cover.jpg", olByValue, 0
        .Attachments.Add TempFilePath & "subs.jpg", olByValue, 0
        'You can add a file like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With

    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 ("ReceivedTime")
    ' Determine date of each message:
    For Each myItem In myItems
        dateStr = GetDate(myItem.ReceivedTime)
        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

    Dim fso As Object
    Dim fo As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fo = fso.CreateTextFile("C:\Users\x152833\outlook_log.txt")
    fo.Write msg
    fo.Close

    Set fo = Nothing
    Set fso = Nothing
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing
End Sub

Answer 1

unreadCount = myItems.Restrict("[Unread] = true").Count

您还可以尝试使用PR_CONTENT_UNREAD读取"http://schemas.microsoft.com/mapi/proptag/0x36030003" MAPI属性（DASL名称MAPIFolder.PropertyAccessor.GetProperty）（不保证该属性存在）。如果该属性不存在，您可以捕获异常并回退到Items.Restrict，这总是有效，但很多效率低于PR_CONTENT_UNREAD。

查看包含OutlookSpy的文件夹（单击IMAPIFolder按钮），检查您的特定情况下是否有PR_CONTENT_UNREAD属性。

Answer 2

结果很简单，你所要做的就是遍历objfolder对象的Items集合并检查这些项目的UnRead属性：

For Each i In objFolder.items

    If (i.UnRead) Then

        EmailCount = EmailCount + 1

    End If

Next

但是，我强烈建议删除所有名为objFolderxy和EmailCountxy的变量。有一个更好的方法来做到这一点。请考虑以下示例：

Sub GetFolderStats()

Dim objOutlook As Object, objnSpace As Object, objFolder As Object

Dim d
Set d = CreateObject("Scripting.Dictionary")

Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

Set objFolder = objnSpace.Folders("Mailbox - CENSORED").Folders("Inbox").Folders("Suppliers")

For Each folder In objFolder.Folders

    emailcount = 0

    For Each i In folder.items

        If (i.UnRead) Then

            emailcount = emailcount + 1

        End If

    Next

    d.Add folder.Name, emailcount

Next

Set d = Nothing
Set objOutlook = Nothing
Set objnSpace = Nothing
Set objFolder = Nothing

End Sub

现在，您可能根本不需要字典，只是想举例说明如何迭代电子邮件文件夹而不是明确指定其名称。

当然，您可以动态创建html标记，而不是将这些数据存储在字典中，因此无需处理保存for循环的字典。

希望我能帮忙......