修改Outlook VBA宏：将保存邮件改为提取附件至指定格式文件夹

Let's adjust your existing macro to focus on extracting attachments instead of saving the entire email. The updated code will:

• Let you select a target directory via a browse window
• Create a unique folder for each selected email, named ddmmyyyy - SUBJECT (with invalid characters removed)
• Save all attachments from the email into that folder (handling duplicate filenames automatically)

Here's the full working code:

Option Explicit

Sub Save_Attachments_From_Selected_Mails()
    Dim olItem As MailItem
    Dim targetBasePath As String
    
    ' Let user select the base folder to save attachments
    targetBasePath = BrowseForFolder(CStr(Environ("USERPROFILE")) & "\desktop\")
    If targetBasePath = False Then Exit Sub ' User cancelled browse dialog
    
    targetBasePath = targetBasePath & Chr(92)
    
    ' Process each selected mail item
    For Each olItem In Application.ActiveExplorer.Selection
        If olItem.Class = OlObjectClass.olMail Then
            SaveEmailAttachments olItem, targetBasePath
            DoEvents
        End If
    Next olItem
    
    Set olItem = Nothing
    MsgBox "Attachment extraction complete!", vbInformation
End Sub

Private Sub SaveEmailAttachments(olItem As MailItem, basePath As String)
    Dim mailFolderName As String
    Dim finalFolderPath As String
    Dim attachment As Attachment
    Dim cleanedSubject As String
    Dim receivedDateStr As String
    
    ' Create folder name: ddmmyyyy - SUBJECT
    receivedDateStr = Format(olItem.ReceivedTime, "ddmmyyyy")
    cleanedSubject = CleanFileName(olItem.Subject)
    mailFolderName = receivedDateStr & " - " & cleanedSubject
    
    ' Get unique folder path (adds (1), (2), etc. if folder exists)
    finalFolderPath = GetUniqueFolderPath(basePath & mailFolderName)
    
    ' Create the folder if it doesn't exist
    CreateFolderIfNotExists finalFolderPath
    
    ' Save each attachment to the folder
    For Each attachment In olItem.Attachments
        ' Skip embedded attachments (like inline images in signatures)
        If Not attachment.Type = olEmbeddeditem Then
            SaveAttachmentWithUniqueName attachment, finalFolderPath
        End If
    Next attachment
    
    Set attachment = Nothing
End Sub

Private Function CleanFileName(rawName As String) As String
    ' Remove characters that are invalid in Windows filenames/folders
    Dim invalidChars As Variant
    invalidChars = Array(":", "/", "\", "*", "?", """", "<", ">", "|")
    
    CleanFileName = rawName
    Dim char As Variant
    For Each char In invalidChars
        CleanFileName = Replace(CleanFileName, char, "-")
    Next char
    
    ' Trim any leading/trailing spaces
    CleanFileName = Trim(CleanFileName)
End Function

Private Function GetUniqueFolderPath(baseFolderPath As String) As String
    Dim folderPath As String
    Dim counter As Integer
    counter = 1
    
    folderPath = baseFolderPath
    Do While FolderExists(folderPath)
        folderPath = baseFolderPath & "(" & counter & ")"
        counter = counter + 1
    Loop
    
    GetUniqueFolderPath = folderPath
End Function

Private Sub CreateFolderIfNotExists(folderPath As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(folderPath) Then
        fso.CreateFolder folderPath
    End If
    
    Set fso = Nothing
End Sub

Private Sub SaveAttachmentWithUniqueName(attachment As Attachment, folderPath As String)
    Dim attachmentPath As String
    Dim fileName As String
    Dim fileBaseName As String
    Dim fileExtension As String
    Dim counter As Integer
    
    ' Split filename into base and extension
    fileExtension = LCase(Right(attachment.FileName, Len(attachment.FileName) - InStrRev(attachment.FileName, ".")))
    fileBaseName = Left(attachment.FileName, InStrRev(attachment.FileName, ".") - 1)
    
    counter = 1
    attachmentPath = folderPath & Chr(92) & attachment.FileName
    
    ' Handle duplicate filenames
    Do While FileExists(attachmentPath)
        attachmentPath = folderPath & Chr(92) & fileBaseName & "(" & counter & ")." & fileExtension
        counter = counter + 1
    Loop
    
    ' Save the attachment
    attachment.SaveAsFile attachmentPath
End Sub

Private Function FileExists(filespec As String) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    FileExists = fso.FileExists(filespec)
    Set fso = Nothing
End Function

Private Function FolderExists(folderPath As String) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    FolderExists = fso.FolderExists(folderPath)
    Set fso = Nothing
End Function

' Folder browse dialog function (retained from original code)
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a base folder", 0, OpenAt)
    
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    
    Set ShellApp = Nothing
    
    ' Validate the selected path
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\\"
            If Not Left(BrowseForFolder, 1) = "\\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
    Exit Function
    
Invalid:
    BrowseForFolder = False
End Function

Key Changes & Explanations: #

• Folder Naming: We now generate folders using ddmmyyyy - SUBJECT, with all invalid characters replaced by hyphens to avoid Windows filesystem errors.
• Unique Folders: If a folder with the same name already exists, the macro adds a numeric suffix (e.g., 01102024 - Meeting Notes(1)) to prevent conflicts.
• Attachment Handling: The macro skips embedded items (like signature images) to avoid saving unnecessary files. It also handles duplicate attachment filenames by adding suffixes.
• User Experience: Retains the folder browse dialog so you can pick where to store the attachment folders, and shows a completion message when done.

How to Use: #

1. Open Outlook, press Alt + F11 to open the VBA Editor
2. Insert a new module (Insert > Module)
3. Paste the code above into the module
4. Save the project (make sure to enable macros in Outlook's trust settings)
5. Select one or more emails in Outlook, then run the Save_Attachments_From_Selected_Mails macro

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