The following is the Save Attachment code sample from Teach Yourself Outlook 2003 in 24 Hours. (It works in current versions.)
To use, first create a folder under your My Documents named OLAttachments. Then select one or more messages and run the macro to save and remove the attachments. (May wish to comment out the line that deletes the attachment before testing). Remove or comment out the MsgBox lines after testing.
To delete the attachments without saving them, leave just these lines between the If... and End if. (The macro can also be edited to remove the statements above the If command that are no longer needed.)
If lngCount > 0 Then For i = lngCountb To 1 Step -1 ' Delete the attachment. objAttachments.Item(i).Delete Next i objMsg.Save End If
Copy and paste the code from this page into your ThisOutlookSession project. To do this, you can either move your mouse to the right of the first line and click the Copy button (or view source code button then select all, copy and paste). Or copy it from this text file: Save and Delete Attachments. After pasting the code into the VB Editor, it should be colored similar to the code below. A Red line indicates problems with the line.
In Outlook, press Alt+F11 to open the VBA editor and expand Microsoft Outlook Objects then double click on ThisOutlookSession to open it in the editing pane and Ctrl+V to paste the code.
Public Sub SaveAttachments() Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem 'Object 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 ' Get the path to your My Documents folder strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) On Error Resume Next ' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.Application") ' Get the collection of selected objects. Set objSelection = objOL.ActiveExplorer.Selection ' Set the Attachment folder. strFolderpath = strFolderpath & "OLAttachments" 'Use the MsgBox command to troubleshoot. Remove it from the final code. MsgBox strFolderpath ' Check each selected item for attachments. If attachments exist, ' save them to the Temp folder and strip them from the item. For Each objMsg In objSelection ' This code only strips attachments from mail items. ' If objMsg.class=olMail Then ' Get the Attachments collection of the item. Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count 'Use the MsgBox command to troubleshoot. Remove it from the final code. MsgBox objAttachments.Count If lngCount > 0 Then ' We need to use a count down loop for removing items ' from a collection. Otherwise, the loop counter gets ' confused and only every other item is removed. For i = lngCount To 1 Step -1 ' Save attachment before deleting from item. ' Get the file name. strFile = objAttachments.Item(i).FileName ' Combine with the path to the Temp folder. strFile = strFolderpath & strFile ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFile ' Delete the attachment. objAttachments.Item(i).Delete 'write the save as path to a string to add to the message 'check for html and use html tags in link If objMsg.BodyFormat <> olFormatHTML Then strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" Else strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _ strFile & "'>" & strFile & "</a>" End If 'Use the MsgBox command to troubleshoot. Remove it from the final code. MsgBox strDeletedFiles Next i 'End If ' Adds the filename string to the message body and save it ' Check for HTML body If objMsg.BodyFormat <> olFormatHTML Then objMsg.Body = objMsg.Body & vbCrLf & _ "The file(s) were saved to " & strDeletedFiles Else objMsg.HTMLBody = objMsg.HTMLBody & "</p> <p>" & _ "The file(s) were saved to " & strDeletedFiles & "</p> <p>" End If objMsg.Save 'sets the attachment path to nothing before it moves on to the next message. strDeletedFiles = "" End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub
Frank's Modification
Frank modified the structure to break the code into a single call for each mail item. This way, the code can be used for all items selected, but at the same time a RULE can invoke the code also when incoming mail hits the box. here’s the modification.
Public Sub SaveAttachments() Dim objOL As Outlook.Application Dim pobjMsg As Outlook.MailItem 'Object Dim objSelection As Outlook.Selection ' Get the path to your My Documents folder strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) On Error Resume Next ' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.Application") ' Get the collection of selected objects. Set objSelection = objOL.ActiveExplorer.Selection For Each pobjMsg In objSelection SaveAttachments_Parameter pobjMsg Next ExitSub: Set pobjMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub Public Sub SaveAttachments_Parameter(objMsg As MailItem) Dim objAttachments As Outlook.Attachments Dim i As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strDeletedFiles As String ' Get the path to your My Documents folder strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) On Error Resume Next ' Set the Attachment folder. strFolderpath = strFolderpath & "OLAttachments" ' Get the Attachments collection of the item. Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then ' We need to use a count down loop for removing items ' from a collection. Otherwise, the loop counter gets ' confused and only every other item is removed. For i = lngCount To 1 Step -1 ' Save attachment before deleting from item. ' Get the file name. strFile = objAttachments.Item(i).FileName ' Combine with the path to the Temp folder. strFile = strFolderpath & strFile ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFile ' Delete the attachment. 'objAttachments.Item(i).Delete 'write the save as path to a string to add to the message 'check for html and use html tags in link If objMsg.BodyFormat olFormatHTML Then strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & strFile & "'>" & strFile & "</a>" Else strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" End If Next i End If ' Adds the filename string to the message body and save it [COMMENTED AS THIS FUNCTION WAS NOT DESIRED] ' Check for HTML body ' If objMsg.BodyFormat olFormatHTML Then ' objMsg.Body = objMsg.Body & vbCrLf & _ ' "The file(s) were saved to " & strDeletedFiles ' Else ' objMsg.HTMLBody = objMsg.HTMLBody & "" & _ ' "The file(s) were saved to " & strDeletedFiles & "" ' End If objMsg.Save ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objOL = Nothing End Sub
Augusto's Modification
Augusto made some modifications on Frank’s code, in order to avoid file overwriting when the attachment name is the same as an existing one (i.e. details.txt on a return receipt email). Now, the attachments are saved in the format “SenderName.ReceivedDate.filename.ext” and then the attachment is deleted from the original email.
Here is Augusto's code:
Public Sub SaveAttachments() Dim objOL As Outlook.Application Dim pobjMsg As Outlook.MailItem 'Object Dim objSelection As Outlook.Selection ' Get the path to your My Documents folder strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) On Error Resume Next ' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.Application") ' Get the collection of selected objects. Set objSelection = objOL.ActiveExplorer.Selection For Each pobjMsg In objSelection SaveAttachments_Parameter pobjMsg Next ExitSub: Set pobjMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub Public Sub SaveAttachments_Parameter(objMsg As MailItem) Dim objAttachments As Outlook.Attachments Dim i As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strDeletedFiles As String ' Get the path to your My Documents folder strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) On Error Resume Next ' Set the Attachment folder. strFolderpath = strFolderpath & "\OLAttachments\" ' Get the Attachments collection of the item. Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then ' We need to use a count down loop for removing items ' from a collection. Otherwise, the loop counter gets ' confused and only every other item is removed. For i = lngCount To 1 Step -1 ' Save attachment before deleting from item. ' Get the file name. strFile = objAttachments.Item(i).FileName ' Combine with the path to the Temp folder. strFile = strFolderpath & objMsg.SenderName & "." & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile ' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFile ' Delete the attachment. objAttachments.Item(i).Delete 'write the save as path to a string to add to the message 'check for html and use html tags in link If objMsg.BodyFormat olFormatHTML Then strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & strFile & "'>" & strFile & "</a>" Else strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" End If Next i End If ' Adds the filename string to the message body and save it ' Check for HTML body If objMsg.BodyFormat olFormatHTML Then objMsg.Body = objMsg.Body & vbCrLf & _ "The file(s) were saved to " & strDeletedFiles Else objMsg.HTMLBody = objMsg.HTMLBody & "" & _ "The file(s) were saved to " & strDeletedFiles & "" End If objMsg.Save ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objOL = Nothing End Sub
Delete all attachments in the selected folder
Select a folder and run this code to process all messages in the current folder. The "magic" in this code is using the CurrentFolder object: Set Mail = objOL.ActiveExplorer.CurrentFolder instead of the Selection object.
Public Sub SaveDeleteAttachments() Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem 'Object Dim objAttachments As Outlook.Attachments 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) On Error Resume Next strFolderpath = strFolderpath & "OLAttachments" Set objOL = CreateObject("Outlook.Application") Set Mail = objOL.ActiveExplorer.CurrentFolder For Each objMsg In Mail.Items Set objAttachments = objMsg.Attachments 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 objAttachments.Item(i).Delete If objMsg.BodyFormat <> olFormatHTML Then strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" Else strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _ strFile & "'>" & strFile & "</a>" End If Next i 'End If If objMsg.BodyFormat <> olFormatHTML Then objMsg.Body = objMsg.Body & vbCrLf & _ "The file(s) were saved to " & strDeletedFiles Else objMsg.HTMLBody = objMsg.HTMLBody & "<p>" & _ "The file(s) were saved to " & strDeletedFiles & "</p>" End If objMsg.Save strDeletedFiles = "" End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objOL = Nothing End Sub
I receive emails with email inside. I need the attachments that are inside that embedded email. What should I change to get this to work?
Is it possible to have the file path links posted in the email thread appear at the very top instead of at the bottom?
Sure. Just change the order in the code:
It worked flawlessly. Thank you very much for this. What an incredibly powerful tool!
I'm using the Selected Folder code but am getting the following error when stepping through the code. "objMsg.Body = " Application-defined or object-defined error
and nothing is being written to the email body. Email is in Text format (objMsg.BodyFormat =1).
Thanks.
Hi Diane,
So I have created a folder named "OLAttachments" in my My Documents folder. I have pasted the following code attached in VB under ThisOutlookSession. I have created a Rule with the following parameters:
(doesn't include ")
Apply this rule after the message arrives
from "larry.jones31@live.com.au"
and with "Bonus" in the subject
and which has an attachment
and on this computer only
run "Project1.ThisOutlookSession.SaveAttachments Parameter
When an e-mail hits the account I get the New Mail Alerts with the e-mail received details an 3 options:
Edit Rule
Open Item
Close
I'm not sure where I'm going wrong if you could please help.
That is the new mail alert dialog. Do you have a rule that has that set as the action? If you add stop processing rules to this rule, does the dialog still come up?
Good script - Hope you can help me - I need to save the attachment from INBOX to C:\Temp folder and delete the email from INBOX. How can, I achieve this? Appreciate your help.
Change the path where it sets the special folders:
strFolderpath = "C:\Temp\"
or later in the code where it adds the attachment folder - if you aren't using a subfolder, use just c:\temp here -
strFolderpath = "C:\Temp\OLAttachments"
After it is saved, use this to delete the message.
objMsg.Delete
Which code should, I use (Frank or Augusto)? I have created a folder called OLAttachments within Documents folder. No need to use C:\Temp.
Where exactly, I should use objMsg.Delete -is at the end of Frank or Augusto code?
Is this code correct for usage - I can test this after your confirmation. Appreciate your help,
Great resource. Thank you.
Would it be possible highlight or put in quotes the parts of your code that need to be customized? For example, I am not sure where in your code I need to update with my folder path and/or file names? This would be great to see in your code that auto-saves files as they are received (when new files are received in my subfolder, wanting these saved over an existing file on my C drive)
Because of the way the code is formatted, i can't highlight lines that needed edited, but I usually have a comment at the lines that need changed. Plus, as much as possible, I try to use default paths so the macros "just work"
This is where the folder path is - it uses the documents folder.
strFolderpath = strFolderpath & "OLAttachments"
to use a different folder path, use
strFolderpath = "C:\My New Folder\Attachments"
Can somebody please change this code so is save attachment in next format :
"subject line"+"_"Date,time".pdf :
Public Sub SaveAutoAttach(item As Outlook.MailItem)
Dim object_attachment As Outlook.Attachment
Dim saveFolder As String
' Folder location when I want to save my file
saveFolder = "D:\Data\Archive"
For Each object_attachment In item.Attachments
' Criteria to save .pdf files only
If InStr(object_attachment.DisplayName, ".pdf") Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
Next
End Sub
THANKS