Přejít k hlavnímu obsahu

Jak uložit všechny přílohy z více e-mailů do složky v aplikaci Outlook?

Uložení všech příloh z e-mailu je snadné pomocí vestavěné funkce Uložit všechny přílohy v aplikaci Outlook. Pokud však chcete uložit všechny přílohy z více e-mailů najednou, neexistuje žádná přímá funkce, která by vám mohla pomoci. V každém e-mailu musíte opakovaně použít funkci Uložit všechny přílohy, dokud nebudou z těchto e-mailů uloženy všechny přílohy. To je časově náročné. V tomto článku vám představíme dva způsoby, jak hromadně uložit všechny přílohy z více e-mailů do konkrétní složky v aplikaci Outlook.

Uložte všechny přílohy z více e-mailů do složky pomocí kódu VBA
Několik kliknutí k uložení všech příloh z více e-mailů do složky s úžasným nástrojem


Uložte všechny přílohy z více e-mailů do složky pomocí kódu VBA

Tato část ukazuje kód VBA v podrobném průvodci, který vám pomůže rychle uložit všechny přílohy z více e-mailů do konkrétní složky najednou. Postupujte prosím následovně.

1. Nejprve je třeba vytvořit složku pro ukládání příloh v počítači.

Vstupte do Dokumenty složku a vytvořte složku s názvem „Přílohy“. Viz obrázek:

2. Vyberte e-maily, které přílohy uložíte, a potom stiskněte Další + F11 klávesy pro otevření Microsoft Visual Basic pro aplikace okno.

3. cvaknutí Vložit > Modul k otevření Modul a poté zkopírujte jeden z následujících kódů VBA do okna.

Kód VBA 1: Hromadné ukládání příloh z více e-mailů (ukládání přesně stejných jmenných příloh přímo)

Tipy: Tento kód uloží přesně stejné přílohy jmen přidáním číslic 1, 2, 3 ... za názvy souborů.

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
Kód VBA 2: Hromadné ukládání příloh z více e-mailů (zkontrolujte duplikáty)
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

Poznámky:

1) Pokud chcete uložit všechny přílohy stejných jmen do složky, použijte výše uvedené Kód VBA 1. Před spuštěním tohoto kódu prosím klikněte Tools > Reference, a potom zkontrolujte Microsoft Scripting Runtime pole v Reference - projekt dialogové okno;

doc uložit přílohy07

2) Pokud chcete zkontrolovat duplicitní názvy příloh, použijte prosím kód VBA 2. Po spuštění kódu se zobrazí dialogové okno, které vám připomene, zda chcete duplikované přílohy nahradit, zvolte Ano or Ne na základě vašich potřeb.

5. zmáčkni F5 klíč ke spuštění kódu.

Poté se všechny přílohy ve vybraných e-mailech uloží do složky, kterou jste vytvořili v kroku 1. 

Poznámky: Může existovat Microsoft Outlook vyskakovací okno, klikněte na povolit tlačítko pokračovat.


Uložte všechny přílohy z více e-mailů do složky pomocí úžasného nástroje

Pokud jste nováčkem ve VBA, zde velmi doporučujeme Uložit všechny přílohy užitečnost Kutools pro Outook pro tebe. Pomocí tohoto nástroje můžete rychle uložit všechny přílohy z více e-mailů najednou několika kliknutími pouze v aplikaci Outlook.
Před použitím této funkce prosím nejprve si stáhněte a nainstalujte Kutools pro Outlook.

1. Vyberte e-maily obsahující přílohy, které chcete uložit.

Tip: Podržením ikony můžete vybrat více nesousedících e-mailů Ctrl klíč a vyberte je jeden po druhém;
Nebo vyberte více sousedních e-mailů podržením směna klíč a vyberte první a poslední e-mail.

2. cvaknutí Kutools >Nástroje pro připojeníUložit všechny. Viz snímek obrazovky:

3. V Uložit nastavení , klepněte na tlačítko Pomocí tlačítka vyberte složku, do které se mají přílohy uložit, a poté klepněte na ikonu OK .

3. cvaknutí OK dvakrát v příštím vyskakovacím dialogovém okně, Poté se všechny přílohy ve vybraných e-mailech uloží do určené složky najednou.

Poznámky:

  • 1. Chcete-li uložit přílohy do různých složek na základě e-mailů, zaškrtněte políčko Vytvořte podsložky v následujícím stylu a v rozevíracím seznamu vyberte styl složky.
  • 2. Kromě uložení všech příloh můžete přílohy uložit podle konkrétních podmínek. Například chcete uložit pouze přílohy souboru PDF, jejichž název obsahuje slovo „Faktura“, klikněte prosím na Pokročilé volby tlačítko rozbalte podmínky a poté proveďte konfiguraci podle níže uvedeného obrázku.
  • 3. Pokud chcete automaticky ukládat přílohy při příchodu e-mailu, Automatické ukládání příloh funkce může pomoci.
  • 4. Pro odpojení příloh přímo z vybraných e-mailů slouží ikona Odpojte všechny přílohy vlastnost Kutools pro aplikaci Outlook může vám udělat laskavost.

  Pokud chcete mít bezplatnou (60denní) zkušební verzi tohoto nástroje, kliknutím jej stáhněte, a poté přejděte k použití operace podle výše uvedených kroků.


Související články

Vložte přílohy do těla e-mailové zprávy v Outlooku
Za normálních okolností se přílohy zobrazují v poli Attached ve složeném e-mailu. Zde tento výukový program poskytuje metody, které vám pomohou snadno vložit přílohy do těla e-mailu v aplikaci Outlook.

Automaticky stahovat / ukládat přílohy z Outlooku do určité složky
Obecně lze všechny přílohy jednoho e-mailu uložit kliknutím na Přílohy> Uložit všechny přílohy v Outlooku. Ale pokud potřebujete uložit všechny přílohy ze všech přijatých e-mailů a přijímání e-mailů, nějaký ideální? Tento článek představí dvě řešení automatického stahování příloh z Outlooku do určité složky.

Tiskněte všechny přílohy v jednom / několika e-mailech v Outlooku
Jak víte, vytiskne pouze obsah e-mailu, například záhlaví, tělo, když kliknete na Soubor> Tisknout v aplikaci Microsoft Outlook, ale nevytiskne přílohy. Zde vám ukážeme, jak snadno vytisknout všechny přílohy ve vybraném e-mailu v aplikaci Microsoft Outlook.

Hledejte slova v příloze (obsahu) v Outlooku
Když zadáte klíčové slovo do pole Okamžité hledání v aplikaci Outlook, prohledá toto klíčové slovo v subjektech, tělech, přílohách atd. E-mailů. Nyní ale stačí klíčové slovo prohledat pouze v obsahu přílohy, nějaký nápad? Tento článek ukazuje podrobné kroky pro snadné vyhledávání slov v obsahu přílohy v Outlooku.

Při odpovídání v aplikaci Outlook si ponechejte přílohy
Když přeposíláme e-mailovou zprávu v aplikaci Microsoft Outlook, původní přílohy této e-mailové zprávy zůstanou v přeposlané zprávě. Když však odpovíme na e-mailovou zprávu, původní přílohy nebudou v nové zprávě s odpovědí připojeny. Zde představíme několik triků, jak zachovat původní přílohy při odpovídání v aplikaci Microsoft Outlook.


Nejlepší nástroje pro produktivitu v kanceláři

Kutools pro aplikaci Outlook - Více než 100 výkonných funkcí, které doplní váš Outlook

???? Automatizace e-mailu: Mimo kancelář (k dispozici pro POP a IMAP)  /  Naplánujte odesílání e-mailů  /  Automatická kopie/skrytá kopie podle pravidel při odesílání e-mailu  /  Automatické přeposílání (pokročilá pravidla)   /  Automatické přidání pozdravu   /  Automaticky rozdělte e-maily pro více příjemců na jednotlivé zprávy ...

📨 Email management: Snadné vyvolání e-mailů  /  Blokujte podvodné e-maily podle předmětů a dalších  /  Odstranit duplicitní e-maily  /  pokročilé vyhledávání  /  Konsolidovat složky ...

📁 Přílohy ProDávkové uložení  /  Dávkové odpojení  /  Dávková komprese  /  Automaticky uložit   /  Automatické odpojení  /  Automatické komprimování ...

???? Rozhraní Magic: 😊 Více pěkných a skvělých emotikonů   /  Zvyšte produktivitu své aplikace Outlook pomocí zobrazení s kartami  /  Minimalizujte aplikaci Outlook namísto zavírání ...

???? Zázraky na jedno kliknutí: Odpovědět všem s příchozími přílohami  /   E-maily proti phishingu  /  🕘Zobrazit časové pásmo odesílatele ...

👩🏼‍🤝‍👩🏻 Kontakty a kalendář: Dávkové přidání kontaktů z vybraných e-mailů  /  Rozdělit skupinu kontaktů na jednotlivé skupiny  /  Odeberte připomenutí narozenin ...

Přes 100 Vlastnosti Očekávejte svůj průzkum! Kliknutím sem zobrazíte další informace.

Více       Stažení zdarma      Nákup
 

 

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