Outlook VBA-分配给类别时移动邮件

当我为收件箱分配类别时，我想将电子邮件移动到收件箱的子文件夹中

我从中找到了以下代码，但它不起作用。 它应该将邮件移动到与类别同名的子文件夹中，如果不存在，则创建一个文件夹

我已经在Outlook的安全设置中启用了宏，并插入了一些消息框警报，以确认它确实在运行

代码在此Outlook会话中

    Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items

Private Sub Application_Startup()

    MsgBox "Macros are working"

    Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
    Set xInboxItems = xInboxFld.Items
End Sub

Private Sub xInboxItems_ItemChange(ByVal Item As Object)

MsgBox "Item Changed"

Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean

On Error Resume Next

If Item.Class = olMail Then
    Set xMailItem = Item
    xFlag = False
    If xMailItem.Categories <> "" Then
        Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
        If xFlds.Count <> 0 Then
            For Each xFld In xFlds
                If xFld.Name = xMailItem.Categories Then
                    xFlag = True
                End If
            Next
        End If
        If xFlag = False Then
            Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
        End If
        Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
        xMailItem.Move xTargetFld
    End If
End If
End Sub

Private with events xInboxFld As Outlook.Folder
Private WithEvents xInboxItems作为Outlook.Items
私有子应用程序_启动（）
MsgBox“宏正在工作”
设置xInboxFld=Outlook.Application.Session.GetDefaultFolder（olFolderInbox）
设置xInboxItems=xInboxFld.Items
端接头
私有子xInboxItems\u ItemChange（ByVal项作为对象）
MsgBox“项目已更改”
将xMailItem设置为Outlook.MailItem
将xFlds设置为Outlook.Folders
将xFld设置为Outlook.Folder
将xTargetFld设置为Outlook.Folder
Dim xFlag作为布尔值
出错时继续下一步
如果Item.Class=olMail，则
设置xMailItem=Item
xFlag=False
如果xMailItem.Categories为“”，则
设置xFlds=Application.Session.GetDefaultFolder（olFolderInbox）.Folders
如果xFlds.Count为0，则
对于xFlds中的每个xFld
如果xFld.Name=xMailItem.Categories，则
xFlag=True
如果结束
下一个
如果结束
如果xFlag=False，则
Application.Session.GetDefaultFolder（olFolderInbox）.Folders.Add xMailItem.Categories，olFolderInbox
如果结束
设置xTargetFld=Application.Session.GetDefaultFolder（olFolderInbox）.Folders（xMailItem.Categories）
xMailItem.Move xTargetFld
如果结束
如果结束
端接头

我不知道确切的原因，但今天它突然开始工作了，我之前多次重新启动Outlook，但今天早上我需要强制关闭Outlook后它开始工作。

---

（我甚至不确定它是否因为重新启动而立即开始工作，或者是因为其他原因触发了之后的短时间）

在错误恢复下一步时

只是隐藏错误。删除它-您是否收到错误消息以及在哪一行？为什么不在分配给特定类别时设置规则？规则不起作用，因为它仅在收到邮件时运行，而不是在实际分配给类别时运行。