微软更新后，含‘Through the Specified Account’规则的VBA代码运行时错误

症状 #

• 微软更新后，代码遍历Outlook规则时，只要遇到设置为「通过指定账户（Through the Specified Account）」的规则就会崩溃
• 报错代码行：Set olRule = olRules.Item(i)
• 错误提示：Run-time error '-2146664191 [800c8101]
• 尝试用On Error Resume Next无法跳过错误，删除这类规则后代码可正常执行

原问题代码 #

Private Function FindRule(strRuleName As String) As Boolean
     'error handler
    On Error GoTo ErrorHandler
    
    'default process boolean to failed
    FindRule = False
         
    'open rules object
    Set olRules = Outlook.Application.Session.DefaultStore.GetRules

    'loop through rules to see if the rule is in the rules list    
    If olRules.Count = 0 Then
    'no rules, so it can't exist
        FindRule = False
    Else
    'check the list of rules
        'For i = olRules.Count To 1 Step -1
        For i = 1 To olRules.Count
            Set olRule = olRules.Item(i)
            If olRule.Name = strRuleName Then
                FindRule = True
                Exit For
            End If
        Next i
    End If
    
    'rule not found. let folks know
    If FindRule = False Then
        Err.Raise 60001, "Rule Error", "Rule not found!"
    End If
    
ExitFunction:
    'skip error handler
    Exit Function
    
ErrorHandler:
    'display error
    MsgBox Err.Description, vbExclamation + vbOKCancel, "FindRule - Error: " & CStr(Err.Source)
    'clear error
    Err.Clear
    'return failed boolean
    FindRule = False

End Function

解决方案 #

问题出在全局错误处理会直接终止循环并返回False，我们需要在循环内部针对单个规则的读取操作做局部错误捕获，跳过有问题的规则继续遍历。修改后的代码如下：

Private Function FindRule(strRuleName As String) As Boolean
    'default process boolean to failed
    FindRule = False
         
    'open rules object
    Set olRules = Outlook.Application.Session.DefaultStore.GetRules

    'loop through rules to see if the rule is in the rules list    
    If olRules.Count = 0 Then
        'no rules, so it can't exist
        FindRule = False
    Else
        'check the list of rules
        For i = 1 To olRules.Count
            '针对单个规则读取做局部错误处理
            On Error Resume Next
            Set olRule = olRules.Item(i)
            If Err.Number <> 0 Then
                Err.Clear
                On Error GoTo 0
                GoTo ContinueLoop '跳过当前出错的规则
            End If
            On Error GoTo ErrorHandler '恢复全局错误处理
            
            If olRule.Name = strRuleName Then
                FindRule = True
                Exit For
            End If
ContinueLoop:
        Next i
    End If
    
    'rule not found. let folks know
    If FindRule = False Then
        Err.Raise 60001, "Rule Error", "Rule not found!"
    End If
    
ExitFunction:
    Exit Function
    
ErrorHandler:
    'display error
    MsgBox Err.Description, vbExclamation + vbOKCancel, "FindRule - Error: " & CStr(Err.Source)
    'clear error
    Err.Clear
    'return failed boolean
    FindRule = False
    Resume ExitFunction
End Function

说明 #

• 在读取单个规则Set olRule = olRules.Item(i)时临时启用On Error Resume Next，捕获到错误就清除错误并跳过当前循环
• 处理完单个规则后恢复全局错误处理，避免其他逻辑的错误被忽略
• 这样既可以跳过因微软更新导致的「指定账户规则」读取错误，又能正常查找目标规则

内容的提问来源于stack exchange，提问作者Jim Campbell