如何在Outlook中將多封郵件的所有附件保存到資料夾？

Author: Siluvia Last Modified: 2025-05-12

使用Outlook內建的「全部保存附件」功能，可以輕鬆保存單封郵件中的所有附件。然而，如果你想一次性保存多封郵件中的所有附件，則沒有直接的功能可以幫助你完成。你需要對每封郵件反覆應用「全部保存附件」功能，直到所有附件都被保存下來。這非常耗時。本文介紹了兩種方法，讓你可以輕鬆地將多封郵件中的所有附件批量保存到指定的資料夾中。

使用VBA代碼將多封郵件的所有附件保存到資料夾
 只需幾次點擊即可使用一款神奇工具將多封郵件的所有附件保存到資料夾

使用VBA代碼將多封郵件的所有附件保存到資料夾

本節通過逐步指南演示了一段VBA代碼，幫助你快速將多封郵件中的所有附件一次性保存到指定的資料夾中。請按照以下步驟操作：

1. 首先，你需要在電腦上創建一個用於保存附件的資料夾。

進入「文件」資料夾並創建一個名為「Attachments」的資料夾。參見截圖：

2. 選擇包含要保存附件的郵件，然後按下「Alt」+「F11」鍵打開「Microsoft Visual Basic for Applications」窗口。

3. 點擊「插入」>「模塊」以打開「模塊」窗口，然後將以下VBA代碼之一複製到窗口中。

VBA代碼1：從多封郵件中批量保存附件（直接保存同名附件）

注意：此代碼會在文件名後添加數字1、2、3...來保存完全同名的附件。

Dim GCount As Integer
Dim GFilepath As String
Public Sub SaveAttachments()
'Update 20200821
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
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
            xFilePath = xFolderPath & xAttachments.Item(i).FileName
            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 & "<Error! Hyperlink reference not valid.>"
                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
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
    xPath = xFso.GetParentFolderName(GFilepath) & "\" & xFso.GetBaseName(GFilepath) & " " & GCount & "." + xFso.GetExtensionName(GFilepath)
    FileRename = FileRename(xPath)
End If
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

VBA代碼2：從多封郵件中批量保存附件（檢查重複項）

Public Sub SaveAttachments()
'Update 20200821
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 xYesNo As Integer
Dim xFlag As Boolean
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
For Each xMailItem In xSelection
    Set xAttachments = xMailItem.Attachments
    xAttCount = xAttachments.Count
    xSaveFiles = ""
    If xAttCount > 0 Then
        For i = xAttCount To 1 Step -1
            xFilePath = xFolderPath & xAttachments.Item(i).FileName
            xFlag = True
            If VBA.Dir(xFilePath, 16) <> Empty Then
                xYesNo = MsgBox("The file is exists, do you want to replace it", vbYesNo + vbInformation, "Kutools for Outlook")
                If xYesNo = vbNo Then xFlag = False
            End If
            If xFlag = True Then
                xAttachments.Item(i).SaveAsFile xFilePath
                If xMailItem.BodyFormat <> olFormatHTML Then
                    xSaveFiles = xSaveFiles & vbCrLf & "<Error! Hyperlink reference not valid.>"
                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
End Sub

注意：

1) 如果你想將所有同名附件保存到一個資料夾中，請使用上述「VBA代碼1」。在運行此代碼之前，請點擊「工具」>「引用」，然後在「引用 - 專案」對話框中勾選「Microsoft Scripting Runtime」框。

2) 如果你想檢查是否有重複的附件名稱，請使用「VBA代碼2」。運行代碼後，會彈出一個對話框提醒你是否替換重複的附件，根據需要選擇「是」或「否」。

5. 按下「F5」鍵運行代碼。

然後，所選郵件中的所有附件都會被保存到你在步驟1中創建的資料夾中。

注意：可能會出現一個「Microsoft Outlook」提示框，請點擊「允許」按鈕繼續。

使用一款神奇工具將多封郵件的所有附件保存到資料夾

如果你是VBA新手，這裡強烈推薦你使用「Kutools for Outlook」的「保存所有附件」工具。使用這個工具，你可以通過幾次點擊快速將多封郵件中的所有附件一次性保存下來。

使用 Kutools for Outlook 解鎖極致郵件效率！永久免費獲取 70 項強大功能。立即下載免費版本！

1. 選擇包含要保存附件的郵件。

提示：你可以通過按住「Ctrl」鍵並逐一選擇來選取多封不相鄰的郵件；
或者按住「Shift」鍵並選擇第一封和最後一封郵件來選取多封相鄰的郵件。

2. 點擊「Kutools Plus」>「附件工具」>「保存所有附件」。參見截圖：

3. 在「保存設定」對話框中，點擊按鈕選擇一個資料夾來保存附件，然後點擊「確定」按鈕。

save attachments by kutools for outlook 1

4. 在接下來彈出的對話框中點擊兩次「確定」。然後，所選郵件中的所有附件都會立即保存到指定的資料夾中。

注意：

1. 如果你想根據郵件將附件保存到不同的資料夾中，請勾選「以下列樣式創建子資料夾」框，並從下拉菜單中選擇一種資料夾樣式。
2. 除了保存所有附件外，你還可以根據特定條件保存附件。例如，如果你只想保存文件名包含「Invoice」一詞的PDF文件附件，請點擊「高級選項」按鈕展開條件，然後進行如下配置。
3. 如果你想在郵件到達時自動保存附件，Auto Save attachments 功能可以幫助你。
4. 若要直接從所選郵件中拆離附件，Kutools for Outlook 的 Detach All attachments 功能可以幫你忙。