跳到主要內容

如何將多封電子郵件中的所有附件保存到Outlook中的文件夾?

使用Outlook中的內置“保存所有附件”功能,可以輕鬆保存電子郵件中的所有附件。 但是,如果要一次保存多封電子郵件中的所有附件,則沒有直接功能可以提供幫助。 您需要在每封電子郵件中重複應用“保存所有附件”功能,直到從這些電子郵件中保存所有附件為止。 那很費時間。 在本文中,我們為您介紹了兩種方法,可以在Outlook中輕鬆地將所有電子郵件中的所有附件批量保存到特定文件夾。

使用VBA代碼將所有電子郵件中的所有附件保存到文件夾
只需單擊幾下,即可使用出色的工具將所有電子郵件中的所有附件保存到文件夾


使用VBA代碼將所有電子郵件中的所有附件保存到文件夾

本部分在分步指南中演示了VBA代碼,可幫助您快速將所有附件從多封電子郵件中一次快速保存到特定文件夾。 請執行以下操作。

1.首先,您需要創建一個文件夾,用於將附件保存在計算機中。

進入 文件 文件夾並創建一個名為 “附件”。 見截圖:

2.選擇要保存附件的電子郵件,然後按 其他 + 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腳本運行時 盒子裡 參考-項目 對話框;

doc保存附件07

2)如果要檢查重複的附件名稱,請應用VBA代碼2。運行該代碼後,將彈出一個對話框,提醒您是否替換重複的附件,選擇 or 沒有 根據您的需求。

5。 按 F5 鍵來運行代碼。

然後,所選電子郵件中的所有附件都將保存到您在步驟 1 中創建的文件夾中。 

筆記: 可能有一個 微軟Outlook 彈出提示框,請點擊 按鈕繼續。


使用出色的工具將所有電子郵件中的所有附件保存到文件夾

如果您是VBA的新手,強烈建議您 保存所有附件 的效用 Outook 的 Kutools 為了你。 使用此實用程序,只需單擊幾下即可在Outlook中快速快速地一次保存多封電子郵件中的所有附件。
在應用此功能之前,請 首先下載並安裝Kutools for Outlook.

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

提示: 您可以按住來選擇多個不相鄰的電子郵件 按Ctrl 鍵並一一選擇;
或通過按住選擇多個相鄰的電子郵件 轉移 鍵,然後選擇第一個電子郵件和最後一個電子郵件。

2。 點擊 庫工具 >附件工具保存全部。 看截圖:

3。 在裡面 保存設置 對話框中,單擊 按鈕以選擇一個文件夾來保存附件,然後單擊 OK 按鈕。

3。 點擊 OK 在下一個彈出對話框中兩次,然後將所選電子郵件中的所有附件立即保存在指定的文件夾中。

筆記:

  • 1.如果您想根據電子郵件將附件保存在不同的文件夾中,請檢查 按照以下樣式創建子文件夾 框,然後從下拉菜單中選擇文件夾樣式。
  • 2.除了保存所有附件,您還可以按特定條件保存附件。 例如,您只想保存文件名中包含“發票”字樣的pdf文件附件,請單擊 高級選項 按鈕以擴展條件,然後將其配置為如下所示的屏幕快照。
  • 3.如果要在電子郵件到達時自動保存附件,則 自動保存附件 功能可以提供幫助。
  • 4.要直接從所選電子郵件中分離附件,請 分離所有附件 的特點 Kutools for Outlook 可以幫你一個忙。

  如果您想免費試用(60天)此實用程序, 請點擊下載,然後按照上述步驟進行操作。


相關文章

在Outlook中的電子郵件正文中插入附件
通常,附件顯示在撰寫電子郵件的“附件”字段中。 在此,本教程提供了一些方法來幫助您輕鬆地在Outlook的電子郵件正文中插入附件。

自動將附件從Outlook下載/保存到特定文件夾
一般來說,您可以通過單擊Outlook中的附件>保存所有附件來保存一封電子郵件的所有附件。 但是,如果您需要保存所有收到的電子郵件和收到的電子郵件中的所有附件,那麼理想嗎? 本文將介紹兩種解決方案,可將附件從Outlook自動下載到特定文件夾。

在Outlook中以一封/多封電子郵件打印所有附件
如您所知,當您在Microsoft Outlook中單擊“文件”>“打印”時,它將僅打印電子郵件內容,例如標題,正文,而不會打印附件。 在這裡,我們將向您展示如何在Microsoft Outlook中輕鬆打印所選電子郵件中的所有附件。

在Outlook中的附件(內容)中搜索單詞
當我們在Outlook的“即時搜索”框中鍵入關鍵字時,它將在電子郵件的主題,正文,附件等中搜索關鍵字。但是現在,我只需要在Outlook中僅在附件內容中搜索關鍵字,您知道嗎? 本文介紹了在Outlook中輕鬆搜索附件內容中的單詞的詳細步驟。

在Outlook中回复時保留附件
當我們在Microsoft Outlook中轉發電子郵件時,此電子郵件中的原始附件仍保留在轉發的郵件中。 但是,當我們回復電子郵件時,原始附件將不會附加在新的回复消息中。 在這裡,我們將介紹有關在Microsoft Outlook中回复時保留原始附件的一些技巧。


最佳辦公生產力工具

Kutools for Outlook - 超過 100 種強大的功能可增強您的 Outlook

🤖 人工智慧郵件助手: 具備人工智慧魔力的即時專業電子郵件——一鍵天才回覆、完美語調、多語言掌握。輕鬆改變電子郵件! ……

📧 電子郵件自動化: 外出(適用於 POP 和 IMAP)  /  安排發送電子郵件  /  發送電子郵件時按規則自動抄送/密件副本  /  自動轉送(進階規則)   /  自動添加問候語   /  自動將多收件者電子郵件拆分為單獨的訊息 ...

📨 電子郵件管理: 輕鬆回憶電子郵件  /  按主題和其他人阻止詐騙電子郵件  /  刪除重複的電子郵件  /  進階搜索  /  合併資料夾 ...

📁 附件專業版批量保存  /  批量分離  /  批量壓縮  /  自動保存   /  自動分離  /  自動壓縮 ...

🌟 介面魔法: 😊更多又漂亮又酷的表情符號   /  使用選項卡式視圖提高 Outlook 工作效率  /  最小化 Outlook 而不是關閉 ...

👍 一鍵奇蹟: 使用傳入附件回覆全部  /   反網路釣魚電子郵件  /  🕘顯示寄件者的時區 ...

👩🏼‍🤝‍👩🏻 通訊錄和行事曆: 從選定的電子郵件中大量新增聯絡人  /  將聯絡人群組拆分為各組  /  刪除生日提醒 ...

超過 100特點 等待您的探索! 按此處了解更多。

閱讀更多       免費下載      購買
 

 

Comments (81)
Rated 3.5 out of 5 · 3 ratings
This comment was minimized by the moderator on the site
Thank you for sharing the code. Unfortunately, I tried both with failure. This is what I got - The macros in this project are disabled. Please refer to the online help or documentation of the host application to determine how to enable macros. Thank you.
This comment was minimized by the moderator on the site
Hi,
Please follow the instructions in the screenshot below to check if macros are enabled in the macro settings in your Outlook. After enabling both options, re-run the VBA code.

https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/macro-enabled.png
This comment was minimized by the moderator on the site
Thank you so much.
Rated 5 out of 5
This comment was minimized by the moderator on the site
Thank you for sharing VBA code. This work like magic and is going to save it lots of time!
This comment was minimized by the moderator on the site
Hello friends!

Thanks for sharing this VBA code.

Is there any way to change the location of the save folder?

I share the pc with some colleagues and in this case I need the files to be saved in a password protected folder which is not located in the documents folder.

How can I make this change?

Thank you in advance
This comment was minimized by the moderator on the site
Hi Fabiana,
Change the line 14
xFolderPath = xFolderPath & "\Attachments\"

to
xFolderPath = "C:\Users\Win10x64Test\Desktop\save attachments\1\"

Here "C:\Users\Win10x64Test\Desktop\save attachments\1\" is the folder path in my case.
Don't forget to end the folder path with a slash "\"
This comment was minimized by the moderator on the site
Hello friends!

Thank you for sharing that VBA code.

Is there any way to change the location of the save folder?

I share the pc with some colleagues and in this case I need the files to be saved in a password protected folder which is not located in the documents folder.

How can I make this change?

Thank you in advance
This comment was minimized by the moderator on the site
If you are trying to run the Code that renames duplicate files and keep getting a "User Type Not Defined" error message here is the code fixed. Instead of the "Dim xFso As FileSystemObject" on line 47 it should be "Dim xFso As Variant"
Also added a Message Box to appear at the end of data transfer.

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
MsgBoX prompt:="File Transfer Complete", Title:="Sweatyjalapenos tha Goat"
End Sub

Function FileRename(FilePath As String) As String
Dim xPath As String
Dim xFso As Variant
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
This comment was minimized by the moderator on the site
Very nice script as of 2022-10-19 works great, for me doesn't seem to change original message by adding text. The only thing I changed is I added message received date time to each file name with the following format so it would nicely sort by date time in Windows folder: "yyyy-mm-dd HH-mm-ss ".

Code:

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, xDateFormat 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
xDateFormat = Format(xMailItem.ReceivedTime, "yyyy-mm-dd HH-mm-ss ")
xFilePath = xFolderPath & xDateFormat & 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
This comment was minimized by the moderator on the site
Hi Oigo,
This is a very useful VBA script. Thank you for sharing it.
This comment was minimized by the moderator on the site
Hi crystal,

sorry for not being clear.

I was trying to use the code above mentioned. However, apparently I was doing something wrong. I was thinking that I might need to amend some parts in the code shown. For instance the path where to save the attachments and maybe some other parts. Therefore I was asking if you could share the code highlighting the parts which needs tailoring and how to tailor them.

Many thanks,
BR
This comment was minimized by the moderator on the site
Hi Rokkie,
Did you get any error prompt when the code runs? Or which line in your code is highlighted? I need more details so I can see where you can modify the code.
This comment was minimized by the moderator on the site
Hey crystal,

completeley new to this VBA. Can you share a code to use which shows where I have to amend with an example? As a Rookie it is a bit difficult to figure it out.

I am working via a Ctrix connection. Could this be a blocker for the macro?

Much appreaciate the help.
This comment was minimized by the moderator on the site
Hi Rookie,
Sorry I don't understand what you mean: "Can you share a code to use which shows where I have to amend with an example?"
And the code operates on selected emails in Outlook, Ctrix Connection does not block the macro.
This comment was minimized by the moderator on the site
Hi, I am running this Code 1 to extract .txt files from separate sub-folders of an inbox. It works great out of one sub-folder but not at all out of another sub-folder. I have tried forwarding the relevant email and attachment into other inboxes but no luck. The files are automatically generated and sent to the different sub-folders and only vary by a single letter in their title

Any help much is appreciated
There are no comments posted here yet
Load More
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations