vba - Outlook 共享收件箱中超过 2 天的电子邮件总数/已读/未读/未读

Question

我正在尝试计算当天存储在共享邮箱中的 Outlook 邮件项目，并将这些值存储为 4 个类别：“Total”、“Read”、“Unread”、“Breached”（自它出现以来未读超过 2 天到收件箱）。除了“Breached”之外，每个类别都运行良好，因为它根本不计算它们。我遇到的问题是使用双重条件进行正确的 if 语句，以检查电子邮件是否未读以及是否超过 2 天。

我试过用其他循环遍历项目，但没有帮助。我也尝试过使用 RecievedTime 函数，但它也不起作用。问题出现在以下代码片段中：

For Each olMail In Fldr.Items.Restrict("@SQL=%today(""urn:schemas:httpmail:datereceived"")%")
        j = j + 1
        If olMail.UnRead = True Then
            i = i + 1
        If DateDiff("d", olMail.CreationTime, Now) >= 2 And olMail.UnRead = True Then
            h = h + 1
        End If
        End If

这是其余的代码，为了隐私，我更改了收件箱的名称和

Sub CountSelectedItems()
    Dim olApp As Application
    Dim SelItems As Outlook.Selection
    Dim IntRes As Integer
    Dim StrMsg As String
    Dim olMail As Variant
    Dim Fldr As Folder
    Dim processed As Integer

    Set olApp = Outlook.Application
    Set SelItems = olApp.ActiveExplorer.Selection
    Set Fldr = GetFolderPath("exemplaryName\Inbox")

    i = 0
    j = 0
    h = 0
    For Each olMail In Fldr.Items.Restrict("@SQL=%today(""urn:schemas:httpmail:datereceived"")%")
        j = j + 1
        If olMail.UnRead = True Then
            i = i + 1
        If DateDiff("d", olMail.CreationTime, Now) >= 2 And olMail.UnRead = True Then
            h = h + 1
        End If
        End If
    Next olMail


    processed = j - i
    StrMsg = "Total: " & j & vbNewLine & "Processed: " & processed & vbNewLine & "Not processed: " & i & vbNewLine & "Breached: " & h
    IntRes = MsgBox(StrMsg, vbOKOnly + vbInformation, "Count Selected Outlook Items")
    Call CreateNewMail(j, processed, i, h)
End Sub
' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer

    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function

GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

Sub CreateNewMail(total, processed, unprocessed, breached)
    Dim obApp As Object
    Dim NewMail As MailItem
    Dim MyDate

    MyDate = Date

    Set obApp = Outlook.Application
    Set NewMail = obApp.CreateItem(olMailItem)

    With NewMail
         .Subject = "Processed/Unprocessed mailbox " & Date
         .To = "[e-mail]"
         .Body = "Hi" & vbCrLf & vbCrLf & "As of " & MyDate & " the current KM Mailbox messages status is: " & vbCrLf & "Total: " & total & vbCrLf & "Processed: " & processed & vbCrLf & "Unprocessed: " & unprocessed & vbCrLf & "Breached: " & breached & vbCrLf & vbCrLf & "Kind regards"
         .Display
    End With

    Set obApp = Nothing
    Set NewMail = Nothing
End Sub

标签： vbaoutlook

Answer 1

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
'
' If desperate declare as variant


Sub CountItemsInFolder()

    Dim strMsg As String

    Dim allItems As items
    Dim unreadItems As items

    Dim agedItems As items
    Dim agedUnreadItems As items

    Dim fldr As folder

    Dim processed As Long

    Dim allItemsCount As Long
    Dim unreadItemsCount As Long

    Dim agedItemsCount As Long
    Dim agedUnreadItemsCount As Long

    Dim strFilterUnread As String
    Dim strFilterAged As String

    'Set Fldr = GetFolderPath("exemplaryName\Inbox")
    Set fldr = Session.GetDefaultFolder(olFolderInbox)
    'Debug.Print vbCr & "** folder: " & fldr

    Set allItems = fldr.items
    allItemsCount = allItems.count
    'Debug.Print "items in folder: " & allItemsCount

    ' ** filter for unread items
    strFilterUnread = "[unread]=true"
    'Debug.Print strFilterUnread

    Set unreadItems = allItems.Restrict(strFilterUnread)
    unreadItemsCount = unreadItems.count
    'Debug.Print "unread items in " & fldr & ": " & unreadItemsCount & vbCr

    ' ** filter for aged items
    strFilterAged = "[ReceivedTime]<'" & Format(Date - 2, "DDDDD HH:NN") & "'"
    'Debug.Print strFilterAged

    Set agedItems = allItems.Restrict(strFilterAged)
    agedItemsCount = agedItems.count
    'Debug.Print "aged items in " & fldr & ": " & agedItemsCount

    Set agedUnreadItems = agedItems.Restrict(strFilterUnread)
    agedUnreadItemsCount = agedUnreadItems.count
    'Debug.Print "aged unread items in " & fldr & ": " & agedUnreadItemsCount & vbCr

    processed = allItemsCount - unreadItemsCount

    strMsg = "Total: " & allItemsCount & vbNewLine & "Processed: " & processed & vbNewLine & _
             "Not processed: " & unreadItemsCount & vbNewLine & "Breached: " & agedUnreadItemsCount

    Debug.Print strMsg & vbCr
    'MsgBox strMsg, vbOKOnly + vbInformation, "Count Selected Outlook Items"
    'Call CreateNewMail(allItemsCount, processed, unreadItemsCount, agedUnreadItemsCount)

End Sub