如何修改Outlook VBA代码实现附件按邮件主题名保存

需要实现Outlook指定文件夹邮件的批量例行处理：

• 选择本地目标文件夹，将选中Outlook文件夹内所有邮件的附件保存到本地
• 附件保存完成后，删除邮件内的原附件
• 保存的附件不使用原始文件名，直接使用所属邮件的主题作为文件名（已知每封邮件仅含1个附件）
• 基于现有VBA代码修改实现上述命名规则

原有待修改代码如下：

Sub Spremanje()
    ' Ask the user to select a file system folder for saving the attachments
    Dim oShell As Object
    Set oShell = CreateObject("Shell.Application")
    Dim fsSaveFolder As Object
    Set fsSaveFolder = oShell.BrowseForFolder(0, "Mapa za spremanje izvještaja", 1)
    If fsSaveFolder Is Nothing Then Exit Sub
    ' Note:  BrowseForFolder doesn't add a trailing slash

    ' Ask the user to select an Outlook folder to process
    Dim olPurgeFolder As Outlook.MAPIFolder
    Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
    If olPurgeFolder Is Nothing Then Exit Sub

    ' Iteration variables
    Dim msg As Outlook.MailItem
    Dim att As Outlook.Attachment
  
    Dim sSavePathFS As String
    Dim sDelAtts

    For Each msg In olPurgeFolder.Items

    sDelAtts = ""

    ' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
    ' on our olPurgeFolder.Items collection.  The collection returned by the Restrict method
    ' will be dynamically updated each time we remove an attachment.  Each update will
    ' reindex the collection.  As a result, it does not provide a reliable means for iteration.
    ' This is why the For Each loops will not work.
    If msg.Attachments.Count > 0 Then

      ' This While loop is controlled via the .Delete method
      ' which will decrement msg.Attachments.Count by one each time.
      While msg.Attachments.Count > 0

        ' Save the file
        sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Subject(1).FileName
        msg.Attachments(1).SaveAsFile sSavePathFS

        ' Build up a string to denote the file system save path(s)
        ' Format the string according to the msg.BodyFormat.
        If msg.BodyFormat <> olFormatHTML Then
            sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
        Else
            sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
        End If

        ' Delete the current attachment.  We use a "1" here instead of an "i"
        ' because the .Delete method will shrink the size of the msg.Attachments
        ' collection for us.  Use some well placed Debug.Print statements to see
        ' the behavior.
        msg.Attachments(1).Delete

      Wend

      ' Modify the body of the msg to show the file system location of
      ' the deleted attachments.
      If msg.BodyFormat <> olFormatHTML Then
        msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts
      Else
        msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts & "</p>"
      End If

      ' Save the edits to the msg.  If you forget this line, the attachments will not be deleted.
      msg.Save

    End If

    Next

End Sub

原代码存在两个核心问题：

1. 拼接保存路径的语句存在语法错误：msg.Subject是存储邮件主题的字符串属性，不存在(1).FileName的调用方法，运行会直接报错
2. 未处理Windows系统文件名的非法字符：邮件主题可能包含\ / : * ? " < > |这类系统禁止在文件名中使用的字符，直接用主题做文件名会导致保存失败

针对需求修改后的完整代码如下，关键逻辑已添加中文注释：

Sub Spremanje()
    ' 选择本地附件保存文件夹
    Dim oShell As Object
    Set oShell = CreateObject("Shell.Application")
    Dim fsSaveFolder As Object
    Set fsSaveFolder = oShell.BrowseForFolder(0, "请选择附件保存文件夹", 1)
    If fsSaveFolder Is Nothing Then Exit Sub

    ' 选择要处理的Outlook文件夹
    Dim olPurgeFolder As Outlook.MAPIFolder
    Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
    If olPurgeFolder Is Nothing Then Exit Sub

    ' 迭代变量声明
    Dim msg As Object
    Dim att As Outlook.Attachment
    Dim sSavePathFS As String
    Dim sDelAtts As String
    Dim sFileName As String
    Dim sFileExt As String
    Dim invalidChars As Variant
    Dim i As Integer

    ' 定义Windows文件名禁止使用的非法字符
    invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")

    For Each msg In olPurgeFolder.Items
        sDelAtts = ""
        ' 跳过非邮件类型的条目（会议邀请、待办等）
        If msg.Class = olMail And msg.Attachments.Count > 0 Then
            While msg.Attachments.Count > 0
                Set att = msg.Attachments(1)
                ' 提取附件原始扩展名，避免保存后文件无法识别打开
                If InStrRev(att.FileName, ".") > 0 Then
                    sFileExt = LCase(Right(att.FileName, Len(att.FileName) - InStrRev(att.FileName, ".")))
                Else
                    sFileExt = ""
                End If
                
                ' 清理邮件主题中的非法字符，作为文件名主体
                sFileName = msg.Subject
                For i = LBound(invalidChars) To UBound(invalidChars)
                    sFileName = Replace(sFileName, invalidChars(i), "_")
                Next
                
                ' 拼接完整保存路径
                If sFileExt <> "" Then
                    sSavePathFS = fsSaveFolder.Self.Path & "\" & sFileName & "." & sFileExt
                Else
                    sSavePathFS = fsSaveFolder.Self.Path & "\" & sFileName
                End If
                
                ' 保存附件
                att.SaveAsFile sSavePathFS

                ' 记录保存路径用于写入邮件正文
                If msg.BodyFormat <> olFormatHTML Then
                    sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
                Else
                    sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
                End If

                ' 删除已保存的附件
                att.Delete
            Wend

            ' 邮件正文追加附件删除、保存记录
            If msg.BodyFormat <> olFormatHTML Then
                msg.Body = msg.Body & vbCrLf & vbCrLf & "附件已删除:  " & Date & " " & Time & vbCrLf & vbCrLf & "保存路径:  " & vbCrLf & sDelAtts
            Else
                msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "附件已删除:  " & Date & " " & Time & "<br><br>保存路径:<br>" & sDelAtts & "</p>"
            End If

            ' 保存邮件修改
            msg.Save
        End If
    Next
End Sub

代码说明 #

• 保留了原代码的可视化文件夹选择、批量遍历、附件删除、正文追加保存记录的核心逻辑
• 自动适配单/多附件场景，完全匹配单附件的使用需求
• 自动将主题中的非法文件名字符替换为下划线，不会因主题格式问题导致保存失败
• 增加了条目类型判断，跳过文件夹内的非邮件内容避免运行报错

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