vba outlook count только непрочитанные сообщения?


0

Я использую следующий код vba в Outlook для подсчета всех писем в папке и вложенных папках. Но я хочу изменить свой код, чтобы он учитывал только непрочитанные письма?

Есть ли способ, что я могу сделать это, и если так будет кто-то пожалуйста, быть в состоянии показать мне, как, спасибо заранее

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 
0

Это оказалось довольно легко , все, что вам нужно сделать, это перебирать коллекцию Items ваших объектов objfolder и проверить непрочитанное свойство элементов, как это:

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.

Надежда Я мог бы помочь ...

  0

Любая удача Джек Найт? 21 окт. 142014-10-21 14:06:10


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

Вы также можете попытаться прочитать PR_CONTENT_UNREAD MAPI свойства (имя DASL "http://schemas.microsoft.com/mapi/proptag/0x36030003") с помощью MAPIFolder.PropertyAccessor.GetProperty (свойство не гарантированно присутствовать). Если собственности нет, вы можете поймать исключение и вернуться к Items.Restrict, который всегда работает, но много менее эффективно, чем PR_CONTENT_UNREAD.

Посмотрите на папку с OutlookSpy (нажмите кнопку IMAPIFolder), чтобы проверить, имеется ли свойство PR_CONTENT_UNREAD в вашем конкретном случае.