Перейти до основного матеріалу

Як зберегти всі вкладення з декількох електронних листів до папки в Outlook?

Зберігати всі вкладення з електронної пошти легко за допомогою вбудованої функції Зберегти всі вкладення в Outlook. Однак якщо ви хочете зберегти всі вкладення з декількох електронних листів одночасно, пряма функція не може допомогти. Вам потрібно неодноразово застосовувати функцію Зберегти всі вкладення в кожному електронному листі, доки всі вкладення не будуть збережені з цих електронних листів. Це трудомістко. У цій статті ми вводимо два способи масового збереження всіх вкладень із декількох електронних листів до певної папки в Outlook.

Збережіть усі вкладення з декількох електронних листів у папку з кодом VBA
Кілька кліків, щоб зберегти всі вкладення з декількох електронних листів до папки за допомогою дивовижного інструменту


Збережіть усі вкладення з декількох електронних листів у папку з кодом VBA

Цей розділ демонструє код VBA у покроковому посібнику, який допоможе швидко зберегти всі вкладення з декількох електронних листів одночасно до певної папки. Будь ласка, виконайте наступне.

1. По-перше, вам потрібно створити папку для збереження вкладень у вашому комп’ютері.

Потрапити в документи папку та створіть папку з іменем “Додатки”. Дивіться знімок екрана:

2. Виберіть електронні листи, які вкладення ви збережете, а потім натисніть інший + F11 ключі, щоб відкрити Microsoft Visual Basic для додатків вікна.

3. клацання Insert > Модулі відкрити Модулі вікно, а потім скопіюйте у вікно один із наведених нижче кодів VBA.

Код VBA 1: Масове збереження вкладень із декількох електронних листів (безпосередньо збереження вкладень із однаковим іменем)

Tips : Цей код збереже вкладені файли з однаковими іменами, додавши цифри 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. Перш ніж запускати цей код, натисніть Tools > посилання, а потім перевірте Виконання сценаріїв Microsoft коробка в Список літератури - Проект діалогове вікно;

doc зберегти вкладення07

2) Якщо ви хочете перевірити наявність імен дублікатів вкладень, застосуйте код VBA 2. Після запуску коду з’явиться діалогове вікно, яке нагадуватиме вам, чи слід замінювати дублікати вкладень, виберіть Так or Немає в залежності від потреб.

5 Натисніть кнопку F5 клавіша для запуску коду.

Потім усі вкладення у вибраних електронних листах зберігаються в папці, яку ви створили на кроці 1. 

Примітки: Може бути Microsoft Перспективи спливаюче вікно, натисніть, будь ласка, дозволяти кнопку, щоб продовжити.


Зберігайте всі вкладення з декількох електронних листів у папку за допомогою чудового інструменту

Якщо ви новачок у VBA, тут настійно рекомендуємо Зберегти всі вкладення корисність Kutools для Outook для вас. За допомогою цієї утиліти ви можете швидко зберегти всі вкладення з декількох електронних листів одночасно за допомогою декількох клацань лише в Outlook.
Перш ніж застосовувати функцію, будь ласка спершу завантажте та встановіть Kutools для Outlook.

1. Виберіть електронні листи, що містять вкладення, які потрібно зберегти.

Порада: Ви можете вибрати кілька сусідніх електронних листів, утримуючи клавішу Ctrl клавішу та виберіть їх по черзі;
Або виберіть кілька сусідніх електронних листів, утримуючи клавішу Shift клавішу та виберіть перший і останній електронний лист.

2. клацання Кутулс >Інструменти кріпленняЗберегти все. Дивіться знімок екрана:

3 В зберегти налаштування натисніть діалогове вікно , щоб вибрати папку для збереження вкладень, а потім натисніть кнопку OK кнопки.

3. клацання OK двічі в наступному спливаючому вікні до діалогового вікна, тоді всі вкладення у вибраних електронних листах зберігаються одночасно у зазначеній папці.

Примітки:

  • 1. Якщо ви хочете зберегти вкладення в різних папках на основі електронних листів, перевірте Створіть вкладені папки в наступному стилі і виберіть зі спадного меню стиль папки.
  • 2. Окрім збереження всіх вкладень, ви можете зберігати вкладення за певних умов. Наприклад, ви хочете зберегти лише вкладені файли у форматі PDF, в назві яких є слово "Рахунок", натисніть кнопку Додаткові параметри , щоб розширити умови, а потім налаштуйте, як показано нижче.
  • 3. Якщо ви хочете автоматично зберігати вкладення під час надходження електронної пошти, Автоматичне збереження вкладень ця функція може допомогти.
  • 4. Для від'єднання вкладень безпосередньо від вибраних електронних листів, Від'єднайте всі вкладення особливість Kutools для Outlook може зробити вам користь.

  Якщо ви хочете отримати безкоштовну пробну версію (60 днів) цієї програми, натисніть, щоб завантажити, а потім перейдіть до застосування операції, як описано вище.


Статті по темі

Вставте вкладення в тіло повідомлення електронної пошти в Outlook
Зазвичай вкладення відображаються в полі "Вкладені" у складеному електронному листі. Тут цей підручник містить методи, які допоможуть вам легко вставляти вкладення в тіло електронної пошти в Outlook.

Автоматично завантажувати / зберігати вкладення з Outlook у певну папку
Взагалі кажучи, ви можете зберегти всі вкладення одного електронного листа, натиснувши вкладення> Зберегти всі вкладення в Outlook. Але, якщо вам потрібно зберегти всі вкладення з усіх отриманих електронних листів та отримання електронних листів, будь-який ідеал? У цій статті представлено два рішення для автоматичного завантаження вкладень із Outlook у певну папку.

Роздрукуйте всі вкладення в одному / декількох електронних листах у програмі Outlook
Як відомо, він надрукує вміст електронної пошти, такий як заголовок, тіло, лише натиснувши кнопку Файл> Друк у Microsoft Outlook, але не роздрукує вкладення. Тут ми покажемо вам, як легко роздрукувати всі вкладення у вибраному електронному листі в Microsoft Outlook.

Шукати слова у вкладеному файлі (вмісті) у програмі Outlook
Коли ми вводимо ключове слово у поле миттєвого пошуку в Outlook, воно буде шукати ключове слово в темах електронної пошти, вмісті, вкладеннях тощо. Але тепер мені просто потрібно шукати ключове слово у вмісті вкладень лише в Outlook, будь-яка ідея? Ця стаття показує докладні кроки для легкого пошуку слів у вмісті вкладень у програмі Outlook.

Зберігайте вкладення, відповідаючи в Outlook
Коли ми пересилаємо повідомлення електронної пошти в Microsoft Outlook, оригінальні вкладення в цьому повідомленні електронної пошти залишаються в переадресованому повідомленні. Однак, коли ми відповідаємо на повідомлення електронної пошти, оригінальні вкладення не додаватимуться до нового відповіді. Тут ми збираємось представити кілька прийомів щодо збереження оригінальних вкладень під час відповіді у Microsoft Outlook.


Найкращі інструменти продуктивності офісу

Kutools для Outlook - Понад 100 потужних функцій, які покращать ваш Outlook

🤖 AI Mail Assistant: Миттєві професійні електронні листи з магією штучного інтелекту – геніальні відповіді одним клацанням, ідеальний тон, багатомовна майстерність. Трансформуйте електронну пошту без зусиль! ...

???? Автоматизація електронної пошти: Поза офісом (доступно для POP та IMAP)  /  Розклад надсилання електронних листів  /  Автоматична копія/прихована копія за правилами під час надсилання електронної пошти  /  Автоматичне пересилання (розширені правила)   /  Автоматично додавати привітання   /  Автоматично розділяйте електронні листи кількох одержувачів на окремі повідомлення ...

📨 Управління електронною поштою: Легко відкликайте електронні листи  /  Блокуйте шахрайські електронні листи за темами та іншими  /  Видалити повторювані електронні листи  /  розширений пошук  /  Консолідація папок ...

📁 Вкладення ProПакетне збереження  /  Пакетне від'єднання  /  Пакетний компрес  /  Автозавантаження   /  Автоматичне від'єднання  /  Автокомпресія ...

???? Магія інтерфейсу: 😊Більше красивих і класних смайликів   /  Підвищте продуктивність 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