Outlook VBA：Items_ItemChange触发后邮件重复复制三次问题

问题根源 #

你的代码触发了重复的ItemChange事件循环：给邮件添加分类触发第一次事件后，ItemCopy.Move olFolder操作会修改邮件位置，再次触发ItemChange；甚至保存到外部文件夹的操作也可能触发属性变更，导致多次执行复制逻辑，最终生成多份副本。另外，Item.Categories = Category的判断过于严格，若邮件存在多个分类时会失效。

修正方案 #

1. 操作前禁用事件触发，阻断循环执行路径
2. 改用更严谨的分类存在性判断逻辑
3. 增加邮件位置检查，避免重复处理已移动的邮件

修正后的代码 #

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olNameSpace As Outlook.NameSpace
    Dim olFolder  As Outlook.Folder

    Set olNameSpace = Application.GetNamespace("MAPI")
    Set olFolder = olNameSpace.Folders("Mailbox_Name").Folders("Inbox")
    Set Items = olFolder.Items
End Sub

Private Sub Items_ItemChange(ByVal Item As Object)
    Dim olNameSpace As Outlook.NameSpace
    Dim olTargetFolder  As Outlook.Folder
    Dim olInbox  As Outlook.Folder
    Dim ItemCopy As MailItem
    Dim Category As String
    Dim ExternalFolder As String
    Dim FileName As String
    
    Category = "Test_category"
    ExternalFolder = "C:\MyEmails\"
    
    ' 仅处理邮件类型项
    If Not TypeOf Item Is Outlook.MailItem Then Exit Sub
    
    ' 禁用事件，防止操作触发重复执行
    Application.EnableEvents = False
    
    ' 错误捕获，确保事件最终能恢复
    On Error GoTo Cleanup
    
    Set olNameSpace = Application.GetNamespace("MAPI")
    Set olInbox = olNameSpace.Folders("Mailbox_Name").Folders("Inbox")
    Set olTargetFolder = olInbox.Folders("Copy")

    ' 检查邮件包含目标分类，且当前不在目标文件夹中
    If InStr(1, Item.Categories, Category, vbTextCompare) > 0 And _
       Item.Parent.Name <> olTargetFolder.Name Then
       
        ' 复制并移动到指定子文件夹
        Set ItemCopy = Item.Copy
        ItemCopy.Move olTargetFolder
        
        ' 保存到外部文件夹
        FileName = ExternalFolder & Replace(Replace(Replace(Item.Subject, ":", ""), "/", ""), "\", "") & ".msg"
        Item.SaveAs FileName, olMSG
    End If

Cleanup:
    ' 恢复事件触发，避免影响后续操作
    Application.EnableEvents = True
    ' 释放所有对象变量
    Set Item = Nothing
    Set ItemCopy = Nothing
    Set olNameSpace = Nothing
    Set olInbox = Nothing
    Set olTargetFolder = Nothing
End Sub

关键修改说明 #

• Application.EnableEvents = False：在执行修改邮件的操作前禁用事件，从根源阻止移动、保存操作触发新一轮ItemChange，避免循环执行。
• InStr分类判断：用InStr检查分类字符串中是否包含目标分类，支持邮件同时存在多个分类的场景，比直接等于判断更灵活。
• Item.Parent.Name检查：确保只处理收件箱内的邮件，避免已经移动到目标文件夹的邮件被重复处理。
• 错误处理分支：保证即使代码执行出错，也能恢复事件触发状态，避免Outlook的事件功能异常。

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