请求修改Outlook宏：仅下载主题含“906”的邮件附件

原宏可从Outlook收件箱子文件夹下载附件，但无法筛选主题包含“906”的邮件。以下是修改后的代码，实现仅下载此类邮件中的CSV格式附件：

Sub SaveMail()
    SaveEmailAttachmentsToFolder "Meteologica SA Power Forecast", "csv", ""
End Sub

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim item As Object
    Dim Att As Attachment
    Dim FileName As String
    Dim I As Integer

    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    I = 0
    ' 检查子文件夹是否有邮件，无则退出
    If SubFolder.Items.Count = 0 Then
        MsgBox "该文件夹中无邮件：" & OutlookFolderInInbox, _
               vbInformation, "未找到内容"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    ' 遍历子文件夹中的邮件
    For Each item In SubFolder.Items
        ' 先判断邮件主题是否包含"906"（忽略大小写）
        If InStr(LCase(item.Subject), LCase("906")) > 0 Then
            ' 遍历符合条件的邮件的附件
            For Each Att In item.Attachments
                ' 判断附件是否为CSV格式（忽略大小写）
                If LCase(Right(Att.FileName, Len(ExtString))) = LCase(ExtString) Then
                    DestFolder = "C:\Users\Confi-005\OneDrive - confi.com\Desktop\Schedule\Mail_Temp\Download\"
                    FileName = DestFolder & item.SenderName & " " & Att.FileName
                    Att.SaveAsFile FileName
                    I = I + 1
                End If
            Next Att
        End If
    Next item

    ' 提示结果
    If I > 0 Then
        MsgBox "文件已保存至：" _
             & DestFolder, vbInformation, "完成！"
    Else
        MsgBox "未找到符合条件的附件。", vbInformation, "完成！"
    End If

ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Exit Sub

ThisMacro_err:
    MsgBox "发生意外错误。" _
         & vbCrLf & "请记录并报告以下信息：" _
         & vbCrLf & "宏名称: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "错误代码: " & Err.Number _
         & vbCrLf & "错误描述: " & Err.Description _
         , vbCritical, "错误！"
    Resume ThisMacro_exit
End Sub

修改说明 #

1. 修正筛选逻辑：原代码错误地检查未赋值的strAttachmentName变量，改为检查邮件的Subject属性，通过InStr(LCase(item.Subject), LCase("906")) > 0实现不区分大小写的主题包含判断。
2. 优化遍历顺序：先判断邮件主题是否符合条件，再遍历其附件，减少无效的附件遍历操作。
3. 清理无用变量：移除未使用的MyDocPath、wsh、fs、strAttachmentName变量，简化代码。

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