Come salvare tutti gli allegati da più e-mail nella cartella in Outlook?
È facile salvare tutti gli allegati da un'e-mail con la funzione Salva tutti gli allegati incorporata in Outlook. Tuttavia, se desideri salvare tutti gli allegati da più e-mail contemporaneamente, non è disponibile alcuna funzione diretta. È necessario applicare ripetutamente la funzione Salva tutti gli allegati in ogni e-mail fino a quando tutti gli allegati non vengono salvati da tali e-mail. Questo richiede tempo. In questo articolo, introduciamo due metodi per salvare in blocco tutti gli allegati da più e-mail in una cartella specifica facilmente in Outlook.
Salva tutti gli allegati da più email nella cartella con il codice VBA
Questa sezione mostra un codice VBA in una guida passo passo per aiutarti a salvare rapidamente tutti gli allegati da più email in una cartella specifica contemporaneamente. Si prega di fare quanto segue.
1. Innanzitutto, è necessario creare una cartella per salvare gli allegati nel computer.
Entra nel Documenti cartella e creare una cartella denominata "Allegati". Visualizza gli screenshot:
2. Selezionare i messaggi di posta elettronica che verranno salvati negli allegati, quindi premere altro + F11 chiavi per aprire il Microsoft Visual Basic, Applications Edition finestra.
3. Clic inserire > Modulo per aprire il Modulo finestra, quindi copia uno dei seguenti codice VBA nella finestra.
Codice VBA 1: salva in blocco gli allegati da più e-mail (salva direttamente gli allegati con lo stesso nome)
Tip: Questo codice salverà gli allegati con lo stesso nome aggiungendo le cifre 1, 2, 3 ... dopo i nomi dei file.
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
If xSaveFiles <> "" Then
If xMailItem.BodyFormat <> olFormatHTML Then
xMailItem.Body = vbCrLf & "The file(s) were saved to " & xSaveFiles & vbCrLf & xMailItem.Body
Else
xMailItem.HTMLBody = "<p>" & "The file(s) were saved to " & xSaveFiles & "</p>" & xMailItem.HTMLBody
End If
End If
xMailItem.Save
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
Codice VBA 2: salva in blocco gli allegati da più e-mail (controlla i duplicati)
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
If xSaveFiles <> "" Then
If xMailItem.BodyFormat <> olFormatHTML Then
xMailItem.Body = vbCrLf & "The file(s) were saved to " & xSaveFiles & vbCrLf & xMailItem.Body
Else
xMailItem.HTMLBody = "<p>" & "The file(s) were saved to " & xSaveFiles & "</p>" & xMailItem.HTMLBody
End If
End If
xMailItem.Save
End If
Next
Set xAttachments = Nothing
Set xMailItem = Nothing
Set xSelection = Nothing
End Sub
Note:
1) Se si desidera salvare tutti gli allegati con lo stesso nome in una cartella, applicare quanto sopra Codice VBA 1. Prima di eseguire questo codice, fare clic su Strumenti > Referenzee quindi controllare il Runtime di script Microsoft casella nella Riferimenti - Progetto la finestra di dialogo;
2) Se si desidera verificare la presenza di nomi di allegati duplicati, applicare il codice VBA 2. Dopo aver eseguito il codice, verrà visualizzata una finestra di dialogo per ricordare se sostituire gli allegati duplicati, scegliere Sì or Non in base alle proprie esigenze.
5. premi il F5 chiave per eseguire il codice.
Quindi tutti gli allegati nelle e-mail selezionate vengono salvati nella cartella creata nel passaggio 1. Vedrai che ci sono collegamenti ipertestuali visualizzati nelle e-mail selezionate. Fare clic sul collegamento per aprire automaticamente l'allegato specifico.
Nota: Potrebbe esserci un Microsoft Outlook finestra di messaggio che si apre, fare clic su Consentire pulsante per andare avanti.
Salva tutti gli allegati da più email in una cartella con uno strumento straordinario
Se sei un principiante in VBA, qui altamente raccomandato il Salva tutti gli allegati utilità di Kutools per Outook per te. Con questa utility, puoi salvare rapidamente tutti gli allegati da più e-mail contemporaneamente con diversi clic solo in Outlook. Prima di applicare la funzione, per favore scarica e installa prima Kutools per Outlook.
1. Selezionare le e-mail contenenti gli allegati che si desidera salvare.
Suggerimenti: Puoi selezionare più email non adiacenti tenendo premuto il tasto Ctrl tasto e selezionarli uno per uno; Oppure seleziona più email adiacenti tenendo premuto il tasto spostamento e seleziona la prima e-mail e l'ultima.
2. Clic Kutools >Strumenti per gli allegati > Salva tutto. Vedi screenshot:
3. Nel Salva impostazioni finestra di dialogo, fare clic su per selezionare una cartella in cui salvare gli allegati, quindi fare clic su OK pulsante.
3. Clic OK due volte nella successiva finestra di dialogo, quindi tutti gli allegati nelle e-mail selezionate vengono salvati nella cartella specificata contemporaneamente.
Note:
1. Se desideri salvare gli allegati in cartelle diverse in base alle e-mail, controlla il file Crea sottocartelle nel seguente stile casella e scegli uno stile di cartella dal menu a discesa.
2. Oltre a salvare tutti gli allegati, è possibile salvare gli allegati in base a condizioni specifiche. Ad esempio, si desidera salvare solo gli allegati del file pdf il cui nome del file contiene la parola "Fattura", fare clic sul pulsante opzioni avanzate per espandere le condizioni, quindi configurare come mostrato di seguito.
3. Se si desidera salvare automaticamente gli allegati all'arrivo di messaggi di posta elettronica, il file Salvataggio automatico degli allegati la funzione può aiutare.
4. Per scollegare gli allegati direttamente dalle e-mail selezionate, il file Scollega tutti gli allegati caratteristica di Kutools per Outlook puoi farti un favore
Se desideri avere una prova gratuita (60 giorni) di questa utility, fare clic per scaricarlo, quindi andare ad applicare l'operazione secondo i passaggi precedenti.
Scarica / salva automaticamente gli allegati da Outlook in una determinata cartella In generale, puoi salvare tutti gli allegati di un'e-mail facendo clic su Allegati> Salva tutti gli allegati in Outlook. Ma se è necessario salvare tutti gli allegati da tutte le e-mail ricevute e ricevute, qualsiasi ideale? Questo articolo introdurrà due soluzioni per scaricare automaticamente gli allegati da Outlook in una determinata cartella.
Stampa tutti gli allegati in una / più email in Outlook Come sai, stamperà solo il contenuto dell'email come intestazione, corpo quando fai clic su File> Stampa in Microsoft Outlook, ma non stampa gli allegati. Qui ti mostreremo come stampare facilmente tutti gli allegati in un'e-mail selezionata in Microsoft Outlook.
Cerca parole all'interno dell'allegato (contenuto) in Outlook Quando digitiamo una parola chiave nella casella di ricerca istantanea in Outlook, cercherà la parola chiave nell'oggetto, nel corpo, negli allegati delle email, ecc. Ma ora devo solo cercare la parola chiave nel contenuto degli allegati solo in Outlook, idea? Questo articolo mostra i passaggi dettagliati per cercare facilmente le parole all'interno del contenuto degli allegati in Outlook.
Conserva gli allegati quando rispondi in Outlook Quando inoltriamo un messaggio di posta elettronica in Microsoft Outlook, gli allegati originali in questo messaggio di posta elettronica rimangono nel messaggio inoltrato. Tuttavia, quando rispondiamo a un messaggio di posta elettronica, gli allegati originali non verranno allegati nel nuovo messaggio di risposta. Qui introdurremo un paio di trucchi per mantenere gli allegati originali quando si risponde in Microsoft Outlook.
Auto CC / BCC dalle regole durante l'invio di e-mail; Avanzamento automatico Email multiple personalizzate; Risposta automatica senza server di scambio e più funzioni automatiche ...
Avviso BCC - mostra il messaggio quando provi a rispondere a tutti se il tuo indirizzo e-mail è nell'elenco BCC; Ricorda quando mancano allegatie altre funzioni di promemoria ...
Rispondi (tutti) con tutti gli allegati nella conversazione di posta; Rispondi a molte email in secondi; Aggiunta automatica di saluto quando rispondi; Aggiungi la data all'oggetto ...
Strumenti per gli allegati: gestisci tutti gli allegati in tutti i messaggi, Scollegamento automatico, Comprimi tutto, Rinomina tutto, Salva tutto ... Rapporto rapido, Conta le email selezionate...
E-mail spazzatura potenti per abitudine; Rimuovi messaggi e contatti duplicati... Consentono di fare in modo più intelligente, veloce e migliore in Outlook.
This has saved me so much time! VBA code 1 doesnt save embedded pictures, where as VBA code 2 does but doesnt rename the file with the same name. Is there a way to have VBA code 1 save the attachments and the embedded files and rename/append any that have the same file name?
Ok, VBA code 1, I just commented out two lines. LINE 29 and LINE 36 - LINE 29 LINE 36 'End If
The VBA code 1 altered for me is as follows. And saves embedded files and attachments and renames them with a 1,2 etc at the end!
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 If xSaveFiles <> "" Then If xMailItem.BodyFormat <> olFormatHTML Then xMailItem.Body = vbCrLf & "The file(s) were saved to " & xSaveFiles & vbCrLf & xMailItem.Body Else xMailItem.HTMLBody = "<p>" & "The file(s) were saved to " & xSaveFiles & "</p>" & xMailItem.HTMLBody End If End If xMailItem.Save 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 has saved me so much time! VBA code 1 doesnt save embedded pictures, where as VBA code 2 does but doesnt rename the file with the same name. Is there a way to have VBA code save the attachments and the embedded files?
Is it possible to have a variation on "VBA Code 2: Bulk Save Attachments From Multiple Emails (Check For Duplicates)" where it automatically replaces a duplicate?
THANK YOU so very much for this script! It has helped me do something I have wanted & needed to do for many years. Are the following modifications still valid for VBA Code 1?
1) This works only if you use the Documents folder. For a more general case: delete line 12 line 15 should read: strFolderpath = "C:\folder\otherfolder\"
4) do not modify the emails in any way (e.g. adding the file save path to the text of the mail), delete line 26-39
Hi! I have used code 1 for many times (can't thank You enough for my saved time) and it run smooth. All of a sudden (outlook 2016), without me changing any of settings, it stopped working with message: "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." I have tried changing settings in Outlook but none of available options gave result (Trust center settings / Macros)
I install Kutools and now I can't run any other macros including this one. I really need to save a whole heap of attachment, but Kutools let's you save emails but it doesn't save attachments too.
Thank you, but only works if the attachments each have different names. For same name attachments, it will just overwrite the previous file. So I edited this VBA script to prefix each file saved with a number:
Public Sub SaveAttachments()
'Update 20191101 Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection Dim i As Long
Dim lngCount As Long Dim strFile As String
Dim strFolderpath As String Dim strDeletedFiles As String
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection strFolderpath = strFolderpath & "\Attachments\"
Dim i2 As Long i2 = 0
For Each objMsg In objSelection i2 = i2 + 1
Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count
strDeletedFiles = "" If lngCount > 0 Then
For i = lngCount To 1 Step -1 strFile = objAttachments.Item(i).FileName
strFile = strFolderpath & CStr(i2) & "_" & strFile objAttachments.Item(i).SaveAsFile strFile
'objAttachments.Item(i).Delete() If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "!>
Works great! if files have different namnes, as stated in earlier comment, I know my files will have same name, can you adjust the code anyway so that it works with same name files? Maybe adding time stamp to the file name? or just digits 1, 2, 3 etc (But not digits after filetype code, eg. ".csv 1"...) Thanks alot!!
Is it possible to name the files based off the subject line. You know how you can edit the subject line from received emails i organize my emails by customer name and date. Can I have the script use the subject line as the file name?
Hi Alan, The code I replied to you before has some problems. I have added new codes to the tutorial, and the problem you mentioned have been solved. Please have a look and try it. Thank you!
So I click the link "Kutools for outlook" and I'm directed to a page that is not that, but "Kutools - Combines More Than 300 Advanced Functions and Tools for Microsoft Excel."
This is what the code is at now, and it does save all the attachments, but it only adds text to the first message. Can anyone help me with this?
Public Sub SaveAttachments() 'Update 20170523 Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem Dim objAttachments As Outlook.Attachments Dim objSelection As Outlook.Selection Dim I As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Set objOL = CreateObject("Outlook.Application") Set objSelection = objOL.ActiveExplorer.Selection strFolderpath = "C:\Users\brianp\Documents\Attachments\" For Each objMsg In objSelection Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count 'Use this to test MsgBox "Subject = " & objMsg.Subject & " lngCount = " & objAttachments.Count If lngCount > 0 Then For I = lngCount To 1 Step -1 strFile = objAttachments.Item(I).FileName strFile = strFolderpath & strFile objAttachments.Item(I).SaveAsFile strFile Next I End If If objMsg.BodyFormat olFormatHTML Then objMsg.Body = vbCrLf & "The Attached file(s) were saved to " & "" & strFile & "" & vbCrLf & objMsg.Body Else objMsg.HTMLBody = "" & "The Attached file(s) were saved to " & "" & strFile & "" & "" & objMsg.HTMLBody End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub
This worked great except for one problem. The attachments in my emails are all named the same thing, so when they copy over, the script keeps replacing the same file with the next attachment in the queue. Is there any way to make it rename them rather than rewrite them?
Hi..I tried everything on here but I keep getting Complile Error block if without end if. I made adjustments per Thomas' suggestions. Heres the code..what am I missing? Any help is appreciated. Public Sub SaveAttachments() 'Update 20130828 Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem Dim objAttachments As Outlook.Attachments Dim objSelection As Outlook.Selection Dim i As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strDeletedFiles As String objOL = CreateObject("Outlook.Application") objSelection = objOL.ActiveExplorer.Selection strFolderpath = "C:\folder\Attachments\" For Each objMsg In objSelection objAttachments = objMsg.Attachments lngCount = objAttachments.Count strDeletedFiles = "" If lngCount > 0 Then For i = lngCount To 1 Step -1 strFile = objAttachments.Item(i).FileName strFile = strFolderpath & strFile objAttachments.Item(i).SaveAsFile strFile DoEvents 'objAttachments.Item(i).Delete() Next ExitSub: objAttachments = Nothing objMsg = Nothing Set objSelection = objOL.ActiveExplorer.Selection objOL = Nothing End Sub
Following on the suggestions above, I had daily system generated emails with attached 'report.txt' and needed to append the sent date to the saved file name in order to avoid overwrites and to distinguish files. Made the following adds in the appropriate places: add- Dim strSent As String add- strSent = Format(objMsg.SentOn, "yymmdd") add- strFile = strSent & strFile
I agree with Stephan on his first two points, see some clarification on his point 3. Finally, adding a DoEvents at the right place should allow you to process large number of emails (just run this code on 157 mails in Outlook 2013).
Some additional thoughts:
1) This works only if you use the Documents folder. For a more general case: delete line 12 line 15 should read: strFolderpath = "C:\folder\otherfolder\"
substitute [i]C:\folder\otherfolder\[/i] with whatever path you have.
2) This code will not delete the attachments, if you want that just delete the leading ' from line 25.
3) If you have big attachments, then probably it is a good idea (as Stephan noted) to put a DoEvents function after line 24.
4) I personally do not want to modify the emails in any way (e.g. adding the file save path to the text of the mail), if you agree with me then you can delete line 26-39.
5) If you skip my step 4, then you can allow the program to modify the emails by checking "Allow access for x time", then you have to click allow only once (c.f. step 6 above in the original).
per selezionare una cartella in cui salvare gli allegati, quindi fare clic su OK pulsante.
