将所有邮件项目标记为已读 - 不包括日历邮件 Items/Requests

Question

我有四个宏，当它们一起使用时，将扫描我的收件箱及其所有子文件夹并将所有未读邮件标记为已读，不包括日历类型的邮件项目。

这是低效的，因为它遍历每个邮件项目。

我有一个不同的脚本，这不是问题，但是，当它遇到日历类型的邮件项目时失败了。

我正在寻找一种将邮件项上的“搜索”条件组合起来标记为已读的方法。

最初，过滤器是这样完成的：

For Each item In strFolderPath.Items.Restrict("[unread] = true")

    item.UnRead = False

Next

如前所述，它在日历类型项目上出错，我绝对会尽最大努力避免 On Error Resume Next。

当前方式：

For Each objMailItem In currentFolder.Items
    
   If TypeName(objMailItem) <> "MeetingItem" And objMailItem.MessageClass <> "IPM.Schedule.Meeting.Request" Then
            
       objMailItem.UnRead = False
            
   End If
                
Next

冗长乏味

CallAll

Sub CallAll()

    '

    Dim InboxFolder As Folder
    Dim SubFolder As Folder
    Dim Folder As Folder
    Dim objInbox As Outlook.MAPIFolder
    
    Set myNamespace = Application.GetNamespace("MAPI")
    Set objInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set InboxFolder = GetFolder(objInbox.FolderPath)
    
    For Each Folder In InboxFolder.Folders
        
        MarkAllRead (Folder.FolderPath)
        
    Next
    
    Set InboxFolder = Nothing
    Set Folder = Nothing
    
End Sub

GetFolder

Function GetFolder(strFolderPath As String) As MAPIFolder

    Dim colFolders As Outlook.Folders
    Dim objFolder As Outlook.MAPIFolder
    Dim arrFolders() As String
    Dim i As Long
    
    strFolderPath = Replace(strFolderPath, "\", "")
    strFolderPath = Replace(strFolderPath, "/", "\")
    
    arrFolders() = Split(strFolderPath, "\")
    
    Set objFolder = Application.GetNamespace("MAPI").Folders.item(arrFolders(0))
    
    If Not objFolder Is Nothing Then
    
        For i = 1 To UBound(arrFolders)
        
            Set colFolders = objFolder.Folders
            Set objFolder = Nothing
            Set objFolder = colFolders.item(arrFolders(i))
            
            If objFolder Is Nothing Then
            
                Exit For
                
            End If
            
        Next
        
    End If
    
    Set GetFolder = objFolder
    Set colFolders = Nothing
    
End Function

GetSubFolder

Function GetSubFolders(strFolderPath As String) As Long

    Dim WalkResultFolder As Folder
    Dim Folder As Folder
    Dim item As MailItem
    Dim WalkResult As Long
    
    Set WalkResultFolder = GetFolder(strFolderPath)
    
    For Each Folder In WalkResultFolder.Folders
    
        WalkResult = GetSubFolders(Folder.FolderPath)
    
        MarkAllRead (Folder.FolderPath)
        
    Next
    
    Set ResultFolder = Nothing
    Set Folder = Nothing
    Set item = Nothing
    
End Function

MarkAllRead

Function MarkAllRead(folderName As String)

    '

    Dim currentFolder As Folder
    Dim objMailItem As MailItem
    
    Set currentFolder = GetFolder(folderName)
    
    For Each objMailItem In currentFolder.Items
    
        Debug.Print "Folder Name: " & currentFolder
        Debug.Print "Mail Item: " & objMailItem
        
        If TypeName(objMailItem) <> "MeetingItem" And objMailItem.MessageClass <> "IPM.Schedule.Meeting.Request" Then
            
            objMailItem.UnRead = False
            
        End If
                
    Next
    
    For Each Folder In currentFolder.Folders
        
        MarkAllRead (Folder.FolderPath)
        
    Next
        
    Set WalkResult = Nothing
    
End Sub

Answer 1

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

Function MarkAllRead(folderName As String)

    Dim SubFolder As Folder
    Dim currentFolder As Folder
    Dim objItem As Object
    Dim objUnreadItems As items
    
    Set currentFolder = GetFolder(folderName)
    Debug.Print "Folder Name: " & currentFolder
    
    Set objUnreadItems = currentFolder.items.Restrict("[Unread]=True")

    For Each objItem In objUnreadItems
        
        If TypeName(objItem) <> "MeetingItem" Then
            Debug.Print "Object Item: " & objItem.Subject
            If objItem.MessageClass <> "IPM.Schedule.Meeting.Request" Then
                objItem.UnRead = False
            End If
        End If
                
    Next
    
    For Each SubFolder In currentFolder.folders
        MarkAllRead (SubFolder.FolderPath)
    Next
        
End Function

将所有邮件项目标记为已读 - 不包括日历邮件 Items/Requests

Mark All Mail Items As Read - Excluding Calendar Mail Items/Requests

outlook

vba