当规则复制项目并移动副本时，ItemAdd 失败

Question

我有一个 ItemAdd 例程，它将添加到收件箱文件夹中的内容标记为已读；然后我有规则调用脚本来检查传入邮件和副本的主题或正文，然后将它们移动到其他子文件夹。

这就是我的理解：当邮件到达并落入调用脚本的规则的条件时，脚本会在 ItemAdd 事件之前执行，但是当 ItemAdd 例程启动时，错误是

运行时错误'-2147221241 (80040107)'：操作失败

这是因为该项目突然不再存在，正如我从即时窗口上的调试活动中了解到的那样。

我尝试使用一种“等待”功能来减慢一个或两个脚本的速度，但这不起作用。

如果我在规则调用的脚本中设置断点，然后逐行单步执行，则 ItemAdd 例程将正确执行，我检查它还在 ItemAdd 例程代码中添加了一个断点，可能调试器将项目对象保留在记忆力。

我可以使用规则将传入邮件标记为已读，或者使用 NewMailEx 事件执行相同的操作，事实上它们都有效，但有一个缺点。使用这些解决方案，我没有收到邮件通知，也没有收到 Windows 任务栏中 Outlook 图标顶部的信封图标（这就是为什么显示桌面警报的规则选项也不能完全实现我的目的），而我却得到了项目添加。

1. ItemAdd 例程将新收件箱项目标记为已读

Private WithEvents allItems As Outlook.Items
Set allItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Private Sub allItems_ItemAdd(ByVal Item As Object)
  Item.UnRead = False
  Item.Save
End Sub

2. 规则调用的脚本（规则不止一条，但行为基本相同）。这里的目的是检查“A”或“B”是否存在，在这种情况下将未读副本移动到正确的文件夹并停止规则处理，否则继续按顺序执行其他规则。

Public Sub Rule_AboutAorB(ByVal Item As Object)
  Dim copiedItem As Object
  Dim colRules As Outlook.Rules
  Dim oRule As Outlook.Rule
  Dim oRuleAction As Outlook.RuleAction
  Set colRules = Application.Session.DefaultStore.GetRules()
    
  Dim AFlag As Boolean
  Dim BFlag As Boolean
  AFlag = False
  BFlag = False
  
  With CreateObject("VBScript.RegExp")
    .Global = True
    .IgnoreCase = True ' <-- case insensitve
    .MultiLine = True
    
    'A
    .Pattern = "\b" & "A" & "\b"
    If .Test(Item.Subject) Or .Test(Item.Body) Then
      AFlag = True
    End If
    
    'B
    .Pattern = "\b" & "B" & "\b"
    If .Test(Item.Subject) Or .Test(Item.Body) Then
      BFlag = True
    End If
    
    If AFlag = True Then
      Set copiedItem = Item.Copy
      copiedItem.UnRead = True
      copiedItem.Move (Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("A"))
      Set oRule = colRules.Item("About A or B (VBA)")
      oRule.Actions.Stop.Enabled = True
      colRules.Save
    ElseIf BFlag = True Then
      Set copiedItem = Item.Copy
      copiedItem.UnRead = True
      copiedItem.Move (Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("B"))
      Set oRule = colRules.Item("About A or B (VBA)")
      oRule.Actions.Stop.Enabled = True
      colRules.Save
    Else
      Set oRule = colRules.Item("About A or B (VBA)")
      oRule.Actions.Stop.Enabled = False
      colRules.Save
    End If
  End With
  
  Set copiedItem = Nothing
  Set Item = Nothing ' This does not really change anything, I put it in a fixing attempt
End Sub

可能会执行另一条不调用脚本的规则，然后运行 ItemAdd 例程，在这种情况下，一切都会顺利进行，因为我复制的邮件未读，原始邮件被读取，我也得到通知。相反，当此规则运行时，它在 ItemAdd 例程之前（正确）运行，然后后者在涉及 Item 时抛出运行时错误。

我想首先了解问题（为什么该项目不再存在），然后修复代码，以便我仍然可以使用 ItemAdd 例程，从而获得通知。

我尝试使用 NewMailEx 或其他简单规则，但没有收到通知。
我尝试调试，但它工作正常。

Answer 1

错误是

MAPI_E_INVALID_ENTRYID

，这是有道理的 - 该项目已消失，因此其条目 ID 不再有效。你有经典的比赛条件。除了忽略错误之外，您无能为力 (

on error resume next

)。

顺便说一句，设置

Save

属性后，您不需要调用

Unread

。

Answer 2

ItemAdd

可以暂时禁用。

可能不运行脚本代码，因为它可能变得更加不可靠。

Option Explicit

Private WithEvents allItems As Items

Private Sub allItems_ItemAdd(ByVal Item As Object)
    Item.unRead = False
End Sub

Sub Application_Startup()
    Set allItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Public Sub Rule_AboutAorB(ByVal Item As Object)

    Dim copiedItem As Object
    
    ' Toggle allItems_ItemAdd off
    Set allItems = Nothing
    
    Set copiedItem = Item.copy
    copiedItem.unRead = True
    copiedItem.Move (Session.GetDefaultFolder(olFolderInbox).Folders("A"))
    
    ' Toggle allItems_ItemAdd on
    Set allItems = Session.GetDefaultFolder(olFolderInbox).Items
    
End Sub