Outlook VBA 因“无法交付”报告而跌跌撞撞答案

【问题标题】：Outlook VBA Stumbling Over "Undeliverable" ReportOutlook VBA 因“无法交付”报告而跌跌撞撞
【发布时间】：2022-07-09 20:43:33
【问题描述】：

我有 VBA 代码，可以将选定的邮件标记为已读，分配一个类别并将它们移动到子文件夹。

邮件递送系统“无法递送”报告未标记为已读、分类或移动。

我尝试复制 For Each 循环以查找 olReportItem。（我意识到有两个循环是低效的，但我这样做只是为了测试目的，所以我可以将所有 beta 代码放在一个部分中。）

Sub TestMoveToSubfolder()
'With selected emails: (1) mark as read, (2) assign category, (3) move to subfolder

On Error Resume Next

    Dim thisFolder As Outlook.MAPIFolder
    Dim objFolder As Outlook.MAPIFolder
    Dim objItem As Outlook.MailItem
    Dim objStore As Store

    Set thisFolder = Application.ActiveExplorer.CurrentFolder
    Set objStore = thisFolder.Store
    Set objFolder = thisFolder.Folders("REFERENCE_DESIRED_FOLDER")
        
    'Be sure target folder exists
    If objFolder Is Nothing Then
        MsgBox "I can't find the designated subfolder.", vbOKOnly + vbExclamation, "INVALID SUBFOLDER"
        Exit Sub
    End If
    
    'Confirm at least one message is selected
    If Application.ActiveExplorer.Selection.Count = 0 Then
        Exit Sub
    End If
    
    'Loop through emails
    For Each objItem In Application.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.UnRead = False
                objItem.Categories = "INSERT_DESIRED_CATEGORY"
                objItem.Move objFolder
            End If
        End If
    Next
    
    'TEST SECTION to work with undeliverable reports
        Dim objItem2 As Outlook.ReportItem
        
        'Loop through nondelivery reports
        For Each objItem2 In Application.ActiveExplorer.Selection
            If objFolder.DefaultItemType = olMailItem Then
                If objItem2.Class = olReportItem Then
                    objItem2.UnRead = False
                    objItem2.Categories = "INSERT_DESIRED_CATEGORY"
                    objItem2.Move objFolder
                End If
            End If
        Next
        
        Set objItem2 = Nothing
    
    Set thisFolder = Nothing
    Set objFolder = Nothing
    Set objItem = Nothing
    Set objStore = Nothing

End Sub

【问题讨论】：

On Error Resume Next 大约有 99.9999999% 的时间被滥用，因此您并不孤单。删除它以查看错误。在网站上搜索解决方案。
olReportItem 类不存在，恐怕。请改用olReport...并评论On Error Resume Next，因为（正确）已在上述评论中说明。 objItem 应声明为 As Variant 或 As Object。

标签： vba outlook

【解决方案1】：

问题与以下方式声明objItem有关：

Dim objItem As Outlook.MailItem

或

Dim objItem2 As Outlook.ReportItem

为了能够遍历 Outlook 中选择的所有项目，您需要在代码中将 objItem 声明为 object。

通常要找出导致问题的确切代码行，您需要删除以下行：

On Error Resume Next

也不需要两个单独的循环，你可以将两个条件组合成一个循环：

Dim objItem As Object

'Loop through emails
For Each objItem In Application.ActiveExplorer.Selection      
  ' check for regular mail items
  If objItem.Class = olMail Then
     objItem.UnRead = False
     objItem.Categories = "INSERT_DESIRED_CATEGORY"
     objItem.Move objFolder
  End If
  ' check for report items
  If objItem.Class = olReportItem Then
     objItem.UnRead = False
     objItem.Categories = "INSERT_DESIRED_CATEGORY"
     objItem.Move objFolder
  End If
Next

【讨论】：

【解决方案2】：

正如我在评论中所说，不存在 olReportItem 类。声明objItem As Variant（或As Object）将允许在所有选择类别之间进行迭代（在一个独特的迭代中。类似的东西：

    Dim objItem 
    For Each objItem In appOutlook.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.UnRead = False
                objItem.Categories = "INSERT_DESIRED_CATEGORY"
                objItem.Move objFolder
            ElseIf objItem.Class = olReport Then
                Stop
                'do whatever you need here...
            End If
        End If
    Next

【讨论】：

【解决方案3】：

为了记录，最终的工作代码如下。我不想将此标记为答案，因为这似乎是我试图为@niton、@FaneDuru 和@Eugene Astafiev 的工作而努力，但由于他们的输入，问题已经得到解答并且问题得到解决.

Sub TestMoveToSubfolder()
'With selected emails: (1) mark as read, (2) assign category, (3) move to subfolder

Dim thisFolder As Outlook.MAPIFolder
Dim objFolder As Outlook.MAPIFolder
Dim objItem As Object 'could also define as Variant
Dim objStore As Store 'used if you want to find subfolder of current mailbox

'set folder locations
    Set thisFolder = Application.ActiveExplorer.CurrentFolder 'alternative is Set thisFolder =  objItem.Parent
    Set objStore = thisFolder.Store 'alternative is to bypass thisFolder and use Set objStore = objItem.Parent.MAPIFolder.Store
    On Error Resume Next
    Set objFolder = thisFolder.Folders("REFERENCE_DESIRED_FOLDER")
    On Error GoTo 0

'Be sure target folder exists
    If objFolder Is Nothing Then
        MsgBox "I can't find the designated subfolder.", vbOKOnly + vbExclamation, "INVALID FOLDER"
        Exit Sub
    End If

'Require that this procedure be called only when a message is selected
    If Application.ActiveExplorer.Selection.Count = 0 Then
        Exit Sub
    End If

'Loop through selected items
    For Each objItem In Application.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.UnRead = False
                objItem.Categories = "INSERT_DESIRED_CATEGORY"
                objItem.Save
                If thisFolder <> objFolder Then objItem.Move objFolder
            ElseIf objItem.Class = olReport Then
                objItem.UnRead = False
                objItem.Categories = "INSERT_DESIRED_CATEGORY"
                objItem.Save
                If thisFolder <> objFolder Then objItem.Move objFolder
            End If
        End If
    Next

'Clean up
    Set thisFolder = Nothing
    Set objFolder = Nothing
    Set objItem = Nothing
    Set objStore = Nothing

End Sub

【讨论】：

【解决方案4】：

非常感谢 @niton、@FaneDura 和 @Eugene Astafiev 的 cmets。我已将这些合并到修改后的代码中，并在项目已经在目标文件夹中时进行了另一项更改以解决错误。代码现在可以工作了，只是当项目已经在目标文件夹中时，有时一切正常，但有时没有添加类别（即使项目被标记为已读）。

如果我单步执行代码，我可以看到它到达类别行，然后毫无错误地越过它，但没有分配类别。我以前从未遇到过这个特殊问题。将类别分配给对象而不是 Outlook.MailItem 是否存在问题？

Sub TestMoveToSubfolder()
'With selected emails: (1) mark as read, (2) assign category, (3) move to subfolder

'On Error Resume Next

    Dim thisFolder As Outlook.MAPIFolder
    Dim objFolder As Outlook.MAPIFolder
    Dim objItem As Object 'could also define as Variant
    Dim objStore As Store

    Set thisFolder = Application.ActiveExplorer.CurrentFolder
    Set objStore = thisFolder.Store
    Set objFolder = thisFolder.Folders("REFERENCE_DESIRED_FOLDER")
    
    'Be sure target folder exists
    If objFolder Is Nothing Then
        MsgBox "I can't find the designated subfolder.", vbOKOnly + vbExclamation, "INVALID FOLDER"
        Exit Sub
    End If
    
    'Require that this procedure be called only when a message is selected
    If Application.ActiveExplorer.Selection.Count = 0 Then
        Exit Sub
    End If
    
    'Loop through selected items
    For Each objItem In Application.ActiveExplorer.Selection
        If objFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.UnRead = False
                objItem.Categories = "INSERT_DESIRED_CATEGORY"
                If thisFolder <> objFolder Then objItem.Move objFolder
            ElseIf objItem.Class = olReport Then
                objItem.UnRead = False
                objItem.Categories = "INSERT_DESIRED_CATEGORY"
                If thisFolder <> objFolder Then objItem.Move objFolder
            End If
        End If
    Next
    
    Set thisFolder = Nothing
    Set objFolder = Nothing
    Set objItem = Nothing
    Set objStore = Nothing

End Sub

【讨论】：

用objItem.Save关注objItem.Categories = "INSERT_DESIRED_CATEGORY"。
文件夹逻辑看起来很狡猾。 objStore 未使用。不管On Error Resume Next 在Set objFolder = thisFolder.Folders("REFERENCE_DESIRED_FOLDER") 之前。关注Set objFolder = thisFolder.Folders("REFERENCE_DESIRED_FOLDER") 和On Error GoTo 0。
您在“objStore”上是正确的。这段代码其实有几个版本，其中一个是寻找当前邮箱的垃圾文件夹，那个里面用到了objstore。我在这里提交了一个瘦版本，以专注于不起作用的部分。
按照@niton 的建议，现在一切正常。为了记录，我做了以下更改：（1）将On Error Resume Next移动到Set objFolder之前； (2) 在Set objFolder 之后插入On Error GoTo 0； (3) 在两次出现objItem.Categories 之后插入objItem.Save。感谢您的帮助！
这看起来更像是一个后续问题，而不是一个答案。既然你已经发布了最终答案，你可以删除这个吗？