Outlook VBA-项目。移动过程随机失败

我有下面的代码

它的问题是，尽管其他一切都很好地工作（类别被分配并成功保存），但有时，随机地，电子邮件不会被移动。我搜索了很多，但没有找到解决方案，也许有人能帮我。无论是邮件项目还是其他类型，这种情况都会发生，而且是随机发生的，而不是特定的文件夹。有时，如果用同一封电子邮件多次尝试，它最终会移动。感谢您的帮助

代码应该做的是： 1） 电子邮件到达 2） 用户指定一个类别 3） 代码继续添加另一个类别，其用户名为分配第一个类别的用户 4） 电子邮件继续移动到与指定类别完全相同的文件夹中

Private with events myOlItems As Outlook.Items
公共子应用程序_启动（）
设置myOlItems=GetFolder（“共享邮箱名称\收件箱”）。项
端接头
私有子myOlItems_ItemChange（ByVal项作为对象）
如果不是，则项目为空
暗淡状态为Outlook.UserProperty
Set status=Item.UserProperties.Find（“已处理”）
如果不是，则项目为空
出错时继续下一步
Cat=项目。类别
错误转到0
如果结束
出错时继续下一步
如果Cat“”和状态“True”而非Cat为空，则
如果Len（Cat）>0，则
user=Application.GetNamespace（“MAPI”）.CurrentUser
用户=替换（用户，，，“”）
Item.Categories=Cat&“Categories”&Cat&“分配人：”&用户
status.Value=“True”
项目。保存
Item.Move（GetFolder（“共享邮箱\收件箱”）。文件夹（“子文件夹名称”）。文件夹（Cat））
猫=没有
状态=无
设置myOlItems=GetFolder（“共享邮箱名称\收件箱”）。项
如果结束
ElseIf Cat=“”和status=“True”则
status.Value=“False”
状态=无
猫=没有
如果结束
错误转到0
如果结束
端接头

在模块顶部明确放置选项。将Cat声明为字符串变量。您将发现必须删除所有Cat=Nothing代码

删除错误时的第二个

，然后继续下一步
。删除该行后，您将发现需要
设置Status=Nothing
。避免在错误恢复下一步时使用
隐藏错误
，直到您知道如何使其变得有用。有关错误处理信息，请参见此处

这可以可靠地满足您的需求

Option Explicit ' At the top of the module

Private Sub myOlItems_ItemChange(ByVal Item As Object)

    Dim Cat As String
    Dim uSer As String

    If Not Item Is Nothing Then

        Dim status As Outlook.UserProperty
        Set status = Item.UserProperties.Find("Processed")

        If Not Item Is Nothing Then
            On Error Resume Next 'This line does nothing
            Cat = Item.Categories
            On Error GoTo 0
        End If

        ' http://www.cpearson.com/excel/errorhandling.htm
        'On Error Resume Next

        'If Cat <> "" And status <> "True" And Not Cat Is Nothing Then
        If Cat <> "" And status <> "True" Then

            If Len(Cat) > 0 Then

                uSer = Application.GetNamespace("MAPI").CurrentUser
                uSer = Replace(uSer, ",", " ")
                Item.Categories = Cat & ";Category " & Cat & " assigned by: " & uSer
                status.Value = "True"
                Item.Save
                Item.move (GetFolder("SHARED MAILBOX\Inbox").folders("Subfolder name").folders(Cat))
                'Cat = Nothing

                ' status = Nothing
                Set status = Nothing

                'Set myOlItems = GetFolder("SHARED MAILBOX NAME\Inbox").items

            End If

        ElseIf Cat = "" And status = "True" Then
            status.Value = "False"
            'status = Nothing
            Set status = Nothing
            'Cat = Nothing

        End If

        'On Error GoTo 0

    End If

End Sub

模块顶部的“
Option Explicit”
私有子myOlItems_ItemChange（ByVal项作为对象）
暗猫如弦
将用户设置为字符串
如果不是，则项目为空
暗淡状态为Outlook.UserProperty
Set status=Item.UserProperties.Find（“已处理”）
如果不是，则项目为空
错误时，继续下一步“此行不起任何作用
Cat=项目。类别
错误转到0
如果结束
' http://www.cpearson.com/excel/errorhandling.htm
'出现错误时，请继续下一步
“如果Cat”和状态“True”而不是Cat则为空
如果类别为“”，状态为“真”，则
如果Len（Cat）>0，则
uSer=Application.GetNamespace（“MAPI”）.CurrentUser
用户=替换（用户，，，“”）
Item.Categories=Cat&“Categories”&Cat&“分配人：”&用户
status.Value=“True”
项目。保存
Item.move（GetFolder（“共享邮箱\收件箱”）。文件夹（“子文件夹名称”）。文件夹（Cat））
“猫=什么都没有
“状态=无”
设置状态=无
'Set myOlItems=GetFolder（“共享邮箱名称\收件箱”）。项
如果结束
ElseIf Cat=“”和status=“True”则
status.Value=“False”
“状态=无”
设置状态=无
“猫=什么都没有
如果结束
'在出现错误时转到0
如果结束
端接头
请提供一个简单的示例！我的道歉，具体的例子是什么？如何提供一个最小的、完整的和可验证的例子：明白了，我决定发布整个内容，只是因为它是一个非常短的代码，没有太多的内容要经历。如果太长，我深表歉意您发布的代码对于一个最小的示例来说太长了。这将大大减少愿意关注你问题的人的数量！谢谢，我将对此进行测试并返回给您。我已经测试了上面的代码，并且能够跟踪到以下行的错误：theFolder=GetFolder（“共享邮箱\收件箱”）。Folders（“子文件夹”）。Folders（Cat）-似乎大小写都不是问题，因为无论类别如何命名，只要名称相同，它就会移动一些电子邮件。但是，在某些情况下，似乎找不到该文件夹，这就是它无法移动的原因。此外，这不是一个与特定文件夹相关的问题，因为它与以前成功将项目移动到其中的文件夹一起失败。如果您愿意，我可以发布GetFolder方法。我对双重发布表示歉意，但我希望将其放在单独的邮件中。进一步分析后，错误出现在尝试获取收件箱下的第一个子文件夹时。如果您确定Outlook忘了在何处查找子文件夹，则可能没有解决方案。第二种引用文件夹的方法在此失败，但您可以尝试。如果文件夹位于导航窗格中，则可以尝试第三种引用文件夹的方法。Session.folders（“共享邮箱名称”）.folders（“收件箱”）.folders（“子文件夹名称”）.folders（Cat）我能够识别出由于缓存模式而发生此问题。如果我们取消选中数据文件属性中的“下载共享文件夹”，问题会得到解决，但Outlook在设置该文件夹时运行速度非常慢
Option Explicit ' At the top of the module

Private Sub myOlItems_ItemChange(ByVal Item As Object)

    Dim Cat As String
    Dim uSer As String

    If Not Item Is Nothing Then

        Dim status As Outlook.UserProperty
        Set status = Item.UserProperties.Find("Processed")

        If Not Item Is Nothing Then
            On Error Resume Next 'This line does nothing
            Cat = Item.Categories
            On Error GoTo 0
        End If

        ' http://www.cpearson.com/excel/errorhandling.htm
        'On Error Resume Next

        'If Cat <> "" And status <> "True" And Not Cat Is Nothing Then
        If Cat <> "" And status <> "True" Then

            If Len(Cat) > 0 Then

                uSer = Application.GetNamespace("MAPI").CurrentUser
                uSer = Replace(uSer, ",", " ")
                Item.Categories = Cat & ";Category " & Cat & " assigned by: " & uSer
                status.Value = "True"
                Item.Save
                Item.move (GetFolder("SHARED MAILBOX\Inbox").folders("Subfolder name").folders(Cat))
                'Cat = Nothing

                ' status = Nothing
                Set status = Nothing

                'Set myOlItems = GetFolder("SHARED MAILBOX NAME\Inbox").items

            End If

        ElseIf Cat = "" And status = "True" Then
            status.Value = "False"
            'status = Nothing
            Set status = Nothing
            'Cat = Nothing

        End If

        'On Error GoTo 0

    End If

End Sub