如何在Outlook中将多封邮件的所有附件保存到文件夹？

Author: Siluvia Last Modified: 2025-07-31

使用Outlook内置的“保存所有附件”功能，可以轻松保存单封邮件中的所有附件。但是，如果你想一次性从多封邮件中保存所有附件，则没有直接的功能可以帮助你完成。你需要反复在每封邮件中应用“保存所有附件”功能，直到所有附件都被保存下来。这非常耗时。本文将介绍两种方法，帮助你在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”的“保存所有附件”工具。使用该工具，你可以通过几次点击轻松地在Outlook中一次性保存多封邮件的所有附件。

使用Kutools for Outlook解锁无与伦比的邮件处理效率！永久免费获取 70 项强大功能。立即下载免费版本！

1. 选择包含要保存附件的邮件。

提示：你可以按住“Ctrl”键并逐个选择多个非连续的邮件；或者按住“Shift”键并选择第一个和最后一个邮件来选择多个连续的邮件。

2. 点击“Kutools Plus” > “Attachment Tools” > “Save All”。参见截图：

3. 在“保存设置”对话框中，点击按钮选择一个文件夹来保存附件，然后点击“确定”按钮。

save attachments by kutools for outlook 1

4. 在接下来弹出的对话框中两次点击“确定”。然后，所选邮件中的所有附件都会一次性保存到指定的文件夹中。

注意事项：

1. 如果你想根据邮件将附件保存到不同的文件夹中，请勾选“以以下样式创建子文件夹”框，并从下拉菜单中选择一种文件夹样式。
2. 除了保存所有附件外，你还可以根据特定条件保存附件。例如，如果你只想保存文件名包含“发票”字样的PDF文件附件，请点击“高级选项”按钮展开条件，然后按如下方式配置。
3. 如果你想在邮件到达时自动保存附件，“Auto Save attachments”功能可以提供帮助。
4. 若要直接从选定的邮件中拆离附件，“Detach All attachments”功能可以为你提供帮助。