如何修改Outlook脚本：批量保存附件并按邮件主题重命名

当然可以实现按邮件主题重命名附件的需求，只需要对现有脚本做几处关键修改，同时处理邮件主题中的非法文件名字符、同一主题多附件的区分以及文件重复的情况。

修改后的完整脚本 #

Dim GCount As Integer
Dim GFilepath As String
Public Sub SaveAttachments()
'Update 20240520 新增按邮件主题重命名附件功能
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.Attachments
Dim xSelection As Outlook.Selection
Dim i As Long
Dim xAttCount As Long
Dim xFilePath As String, xFolderPath As String, xSaveFiles As String
Dim xFso As FileSystemObject
Set xFso = CreateObject("Scripting.FileSystemObject")

On Error Resume Next
xFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
Set xSelection = Outlook.Application.ActiveExplorer.Selection
xFolderPath = xFolderPath & "\Attachments\"
If VBA.Dir(xFolderPath, vbDirectory) = vbNullString Then
    VBA.MkDir xFolderPath
End If
GFilepath = ""
For Each xMailItem In xSelection
    Set xAttachments = xMailItem.Attachments
    xAttCount = xAttachments.Count
    xSaveFiles = ""
    If xAttCount > 0 Then
        For i = xAttCount To 1 Step -1
            GCount = 0
            ' 清理邮件主题中的非法文件名字符
            Dim cleanSubject As String
            cleanSubject = CleanFileName(xMailItem.Subject)
            ' 获取附件后缀
            Dim fileExt As String
            fileExt = ""
            If xFso.GetExtensionName(xAttachments.Item(i).FileName) <> "" Then
                fileExt = "." & xFso.GetExtensionName(xAttachments.Item(i).FileName)
            End If
            ' 生成初始文件路径：主题+序号（多附件时）+后缀
            If xAttCount > 1 Then
                xFilePath = xFolderPath & cleanSubject & " (" & (xAttCount - i + 1) & ")" & fileExt
            Else
                xFilePath = xFolderPath & cleanSubject & fileExt
            End If
            GFilepath = xFilePath
            ' 处理文件重复情况
            xFilePath = FileRename(xFilePath)
            If IsEmbeddedAttachment(xAttachments.Item(i)) = False Then
                xAttachments.Item(i).SaveAsFile xFilePath
                If xMailItem.BodyFormat <> olFormatHTML Then
                    xSaveFiles = xSaveFiles & vbCrLf & xFilePath
                Else
                    xSaveFiles = xSaveFiles & "<br>" & "<a href='file://" & xFilePath & "'>" & xFilePath & "</a>"
                End If
            End If
        Next i
    End If
Next
Set xAttachments = Nothing
Set xMailItem = Nothing
Set xSelection = Nothing
Set xFso = Nothing
End Sub

Function FileRename(FilePath As String) As String
Dim xPath As String
Dim xFso As FileSystemObject
On Error Resume Next
Set xFso = CreateObject("Scripting.FileSystemObject")
xPath = FilePath
FileRename = xPath
If xFso.FileExists(xPath) Then
    GCount = GCount + 1
    ' 基于新的文件名（主题）生成重复文件名
    Dim folderPath As String
    Dim baseName As String
    Dim extName As String
    folderPath = xFso.GetParentFolderName(xPath)
    baseName = xFso.GetBaseName(xPath)
    extName = xFso.GetExtensionName(xPath)
    If extName <> "" Then
        xPath = folderPath & "\" & baseName & " " & GCount & "." & extName
    Else
        xPath = folderPath & "\" & baseName & " " & GCount
    End If
    FileRename = FileRename(xPath)
End If
Set xFso = Nothing
End Function

Function IsEmbeddedAttachment(Attach As Attachment)
Dim xItem As MailItem
Dim xCid As String
Dim xID As String
Dim xHtml As String
On Error Resume Next
IsEmbeddedAttachment = False
Set xItem = Attach.Parent
If xItem.BodyFormat <> olFormatHTML Then Exit Function
xCid = ""
xCid = Attach.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F")
If xCid <> "" Then
    xHtml = xItem.HTMLBody
    xID = "cid:" & xCid
    If InStr(xHtml, xID) > 0 Then
        IsEmbeddedAttachment = True
    End If
End If
End Function

Function CleanFileName(strName As String) As String
    ' 替换Windows文件名中的非法字符为下划线
    Dim illegalChars As Variant
    Dim char As Variant
    illegalChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    CleanFileName = strName
    For Each char In illegalChars
        CleanFileName = Replace(CleanFileName, char, "_")
    Next char
    ' 移除首尾空格
    CleanFileName = Trim(CleanFileName)
End Function

关键修改说明 #

1. 新增CleanFileName函数：处理邮件主题中包含的Windows非法文件名字符（如\ / : * ? " < > |），替换为下划线，避免保存失败。
2. 生成带主题的文件路径：
   • 单附件邮件：直接用清理后的主题作为文件名，保留原附件后缀
   • 多附件邮件：在主题后添加序号（如项目方案 (1).pdf、项目方案 (2).docx），区分同一邮件的不同附件
3. 调整FileRename函数逻辑：适配新的文件名规则，当存在同名文件时，自动在文件名后添加数字序号（如项目方案 1.pdf）
4. 优化保存成功后的提示：将原错误提示改为实际保存的文件路径，方便查看

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