如何避免Outlook宏保存同名邮件附件时出现覆盖问题？

• 原宏问题：仅针对单封邮件内的附件计数，不同邮件的附件会因命名重复被覆盖。
• 修改思路：给附件文件名加入邮件唯一标识（比如主题、接收时间），确保每封邮件的附件命名不重复。

修改后的VBA代码 #

Public Sub SaveAllAttachmentsWithoutOverwrite()
    Dim objSelection As Outlook.Selection
    Dim objMail As Outlook.MailItem
    Dim objAttachment As Outlook.Attachment
    Dim sSaveFolder As String
    Dim sFileName As String
    Dim sCleanSubject As String
    Dim dtReceived As String
    
    ' 设置附件保存路径
    sSaveFolder = "C:\Invoices\"
    
    ' 获取当前选中的邮件
    Set objSelection = Application.ActiveExplorer.Selection
    
    ' 遍历每一封选中的邮件
    For Each objMail In objSelection
        ' 清理邮件主题里的非法文件名字符（比如/:*?"<>|这些）
        sCleanSubject = Replace(objMail.Subject, ":", "")
        sCleanSubject = Replace(sCleanSubject, "\", "")
        sCleanSubject = Replace(sCleanSubject, "/", "")
        sCleanSubject = Replace(sCleanSubject, "*", "")
        sCleanSubject = Replace(sCleanSubject, "?", "")
        sCleanSubject = Replace(sCleanSubject, """", "")
        sCleanSubject = Replace(sCleanSubject, "<", "")
        sCleanSubject = Replace(sCleanSubject, ">", "")
        sCleanSubject = Replace(sCleanSubject, "|", "")
        
        ' 把邮件接收时间转成文件名可用的格式（去掉冒号）
        dtReceived = Format(objMail.ReceivedTime, "yyyy-mm-dd hh-mm-ss")
        
        ' 遍历当前邮件的所有附件
        For Each objAttachment In objMail.Attachments
            ' 组合不重复的文件名：清理后的主题 + 接收时间 + 附件原名
            sFileName = sCleanSubject & " " & dtReceived & " " & objAttachment.FileName
            ' 保存附件到指定路径
            objAttachment.SaveAsFile sSaveFolder & sFileName
        Next objAttachment
    Next objMail
    
    MsgBox "附件批量保存完成！", vbInformation
End Sub

代码说明 #

• 支持批量处理选中的多封邮件，不用逐封手动运行宏
• 用「清理后的邮件主题+接收时间」作为文件名前缀，彻底避免不同邮件的附件重名覆盖
• 自动过滤主题中的非法字符，防止因文件名不合法导致保存失败
• 保留附件原文件名，方便快速识别附件内容

使用步骤 #

1. 打开Outlook，按下Alt + F11打开VBA编辑器
2. 右键左侧项目栏，选择「插入」→「模块」
3. 将上述代码粘贴到模块窗口中
4. 返回Outlook界面，选中需要保存附件的所有邮件
5. 按下Alt + F8，选择SaveAllAttachmentsWithoutOverwrite并点击「运行」

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