Outlook宏代码修复：基于附件文件名移动邮件及处理存量邮件

问题说明 #

每日收到两封主题、正文一致但附件不同的邮件，已通过规则将其移至Outlook收件箱的「Meteologica SA Power Forecast」子文件夹。需要将附件名包含-wind-power-forecast-HrabrovoWind（后缀为.csv）的邮件迁移至收件箱的「Meteologica Hrabrovo Forecast」目标文件夹，但现有宏代码无法正常运行，且无法遍历子文件夹处理已有的邮件。

原代码存在的问题 #

• 依赖未定义的Item变量，仅适用于规则触发场景，无法手动遍历已有邮件
• 存在笔误：obfMail.Move应为objMail.Move
• 未遍历「Meteologica SA Power Forecast」子文件夹内的所有邮件
• 目标文件夹objTargetFolder未提前声明，且仅在找到匹配附件时赋值，无匹配时会引发错误
• 循环内重复获取收件箱文件夹，造成冗余操作

修复优化后的代码 #

以下代码支持手动运行遍历子文件夹内所有已有邮件，同时保留了规则触发的可选功能：

' 手动运行：遍历「Meteologica SA Power Forecast」子文件夹，迁移符合条件的邮件
Sub Move_Hrabrovo_Forecasts()
    Dim ns As NameSpace
    Dim sourceFolder As MAPIFolder
    Dim targetFolder As MAPIFolder
    Dim mail As MailItem
    Dim attachment As Attachment
    Dim isMatch As Boolean
    
    ' 初始化命名空间与文件夹
    Set ns = GetNamespace("MAPI")
    Set sourceFolder = ns.GetDefaultFolder(olFolderInbox).Folders("Meteologica SA Power Forecast")
    Set targetFolder = ns.GetDefaultFolder(olFolderInbox).Folders("Meteologica Hrabrovo Forecast")
    
    ' 遍历源文件夹内所有邮件
    For Each mail In sourceFolder.Items
        ' 仅处理邮件类型项
        If TypeOf mail Is MailItem Then
            isMatch = False
            ' 检查所有附件
            For Each attachment In mail.Attachments
                ' 忽略大小写匹配附件名关键词
                If InStr(LCase(attachment.DisplayName), "-wind-power-forecast-hrabrovowind") > 0 Then
                    isMatch = True
                    Exit For ' 找到匹配附件后退出循环，无需继续检查
                End If
            Next attachment
            
            ' 匹配成功则移动邮件
            If isMatch Then
                mail.Move targetFolder
            End If
        End If
    Next mail
    
    ' 释放对象
    Set attachment = Nothing
    Set mail = Nothing
    Set targetFolder = Nothing
    Set sourceFolder = Nothing
    Set ns = Nothing
End Sub

' 可选：规则触发版本，当新邮件进入源文件夹时自动执行
Sub Rule_Move_Hrabrovo(Item As Object)
    Dim mail As MailItem
    Dim attachment As Attachment
    Dim targetFolder As MAPIFolder
    Dim isMatch As Boolean
    
    If TypeOf Item Is MailItem Then
        Set mail = Item
        isMatch = False
        
        ' 检查附件
        For Each attachment In mail.Attachments
            If InStr(LCase(attachment.DisplayName), "-wind-power-forecast-hrabrovowind") > 0 Then
                isMatch = True
                Exit For
            End If
        Next attachment
        
        ' 移动邮件
        If isMatch Then
            Set targetFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Meteologica Hrabrovo Forecast")
            mail.Move targetFolder
        End If
    End If
    
    Set attachment = Nothing
    Set mail = Nothing
    Set targetFolder = Nothing
End Sub

使用说明 #

1. 打开Outlook，按Alt + F11打开VBA编辑器
2. 将原代码替换为上述代码
3. 若要处理已有的邮件：运行Move_Hrabrovo_Forecasts子过程
4. 若要自动处理新邮件：创建Outlook规则，设置当邮件进入「Meteologica SA Power Forecast」文件夹时，执行Rule_Move_Hrabrovo宏

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