如果在调用脚本的规则之后执行，Outlook VBA ItemAdd 操作将失败

Question

当 ItemAdd 事件例程在调用另一个脚本的规则执行后运行时，我遇到了问题。具体来说，ItemAdd 例程仅负责将添加到收件箱文件夹中的内容标记为已读；然后我有一些规则，其中一些规则调用尽可能多的脚本，这些脚本检查传入邮件的主题或正文并将它们复制到其他子文件夹或 notd。

这就是我所理解的：当邮件到达并落入调用脚本的规则的条件时，脚本会在 ItemAdd 事件之前正确执行，但是当 ItemAdd 例程启动时，错误为“运行时错误'-2147221241 (80040107)'：操作失败。”这是因为该项目突然不存在了，正如我从即时窗口上的一些调试活动中了解到的那样。我还尝试使用一种“等待”功能来减慢一个或两个脚本的速度，但这也不起作用。

一个奇怪的事情是，如果我在规则调用的脚本中设置断点，然后继续逐行单步执行，则 ItemAdd 例程也会正确执行（我检查了它还在 ItemAdd 例程代码中添加了一个断点）并且我真的不知道为什么，可能调试器将项目对象保留在内存中（？）

我知道我可以使用一个简单的规则将传入的邮件标记为已读，或者使用 NewMailEx 事件执行相同的操作，事实上它们都可以正常工作，但有一个同样重要的缺点：使用这些解决方案我没有得到任何结果邮件通知，也不是 Windows 任务栏中 Outlook 图标顶部的信封图标（这就是为什么显示桌面警报的规则选项也不能完全实现我的目的），而是通过 ItemAdd 获得。

这是我的脚本代码：

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或其他简单规则，但没有收到通知。我尝试调试，但它工作正常，与正常运行不同。我已经用完了我的 VBA 知识，这有点差

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