vba 如何只计算未读邮件？

How to count only unread emails?

提问by Hyman Knight

I am using the following vba code in outlook to count all the emails in a folder and subfolders. But I want to edit my code so that it only counts the unread emails.

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

Is there a way I can do this and if so would someone please be able to show me how?

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

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, [email protected]." & 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 = "[email protected]"
        .To = "mark.o'[email protected]"
        .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

回答by Dmitry Streblechenko

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

You can also try to read the PR_CONTENT_UNREADMAPI property (DASL name "http://schemas.microsoft.com/mapi/proptag/0x36030003") using MAPIFolder.PropertyAccessor.GetProperty(the property is not guaranteed to be present). If the property is not present, you can catch the exception and fall back to Items.Restrict, which always works, but is a lotless efficient than PR_CONTENT_UNREAD.

您还可以尝试使用（不保证该属性存在）读取PR_CONTENT_UNREADMAPI 属性（DASL 名称）。如果属性不存在，您可以捕获该异常，并回落到，它总是工作，但很多比效率较低。"http://schemas.microsoft.com/mapi/proptag/0x36030003"MAPIFolder.PropertyAccessor.GetPropertyItems.RestrictPR_CONTENT_UNREAD

Take a look at the folder with OutlookSpy(click IMAPIFolder button) to check if PR_CONTENT_UNREADproperty is available in your particular case.

查看带有OutlookSpy的文件夹（单击 IMAPIFolder 按钮）以检查PR_CONTENT_UNREAD属性是否适用于您的特定情况。

回答by Hyman Knight

It turned out to be quite easy, all you have to do is iterate through the Items collection of your objfolder objects and check the UnRead property of the items like this:

结果证明这很容易，您所要做的就是遍历 objfolder 对象的 Items 集合并检查项目的 UnRead 属性，如下所示：

For Each i In objFolder.items

    If (i.UnRead) Then

        EmailCount = EmailCount + 1

    End If

Next

However, I highly recommend getting rid of all those variables named objFolderxy and EmailCountxy. There is a much better way to do this. Consider the following example:

但是，我强烈建议删除所有名为 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

Now, you might not need the dictionary at all, just wanted to give you an example how you could iterate through the email folders instead of explicitly specifying their names.

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

Of course, instead of storing these data in the dictionary, you could create the html markup on-the-fly thus there would be no need to process the dictionary saving a for loop.

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

Hope I could help...

希望我能帮上忙...