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 & ""
Else
strDeletedFiles = strDeletedFiles & "
" & "" & strFile & ""
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 & " " & _
"The file(s) were saved to " & strDeletedFiles & "
"
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 & "
" & "" & strFile & ""
Else
strDeletedFiles = strDeletedFiles & vbCrLf & ""
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 & "
" & "" & strFile & ""
Else
strDeletedFiles = strDeletedFiles & vbCrLf & ""
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 & ""
Else
strDeletedFiles = strDeletedFiles & "
" & "" & strFile & ""
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 & "" & _
"The file(s) were saved to " & strDeletedFiles & "
"
End If
objMsg.Save
strDeletedFiles = ""
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub 
Andy M says
Do you have a solution for preserving links to folders with spaces in their names? I tried to bracket the link with "<" and ">" like I would if I were writing an email, but it ends up erasing the link altogether...
Diane Poremsky says
Try replacing the spaces with %20. Yes, its ugly, but should definitely work if brackets and quotes around the folder name doesn't work.
Claudia says
ok, I have found a way to avoid that embedded signature pictures (mostly png) are getting deleted. There was a hint far down in the comments: only save/delete certain file types:
look for the line strFile = objAttachments.Item(i).FileName
Add this under
sFileType = LCase$(Right$(strFile, 4))
Select Case sFileType
Case ".pdf", ".doc", ".docx", ".xls", ".xlsx", ".zip"
' only if the file types are found - you can add more
Now look for the line 'write the save as path to a string to add to the message
Add this behind the first End If
End Select
' end selection file types are found
This works very good ;-)
Claudia says
Hi, these macro codes are really helpfull, I use a mix especially with augustos code : delete attachments from selected mails one without saving, one with and deletion info at top of the mail without links only text,
but one thing is still missing and wasn't asked yet:
Is there a way to exclude those?
Thanks in Advance ;-)
Richard says
A user has sent out 150+ individual emails with an attached word doc containing un-compressed images (so the word doc is 8.8Mb) but there are other attachments to each email we need to retain.
So if anyone can provide a script to remove just a specific attachment e.g letter.docx from all emails in the Sent Item folder, it would be a huge help.
Sos says
HI im not a programmer, so i dont undetrstand much of what you are saying could you give me a script for deleting inbox attachments with file type??
Patrick Tingen says
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?
Ben says
Is it possible to have the file path links posted in the email thread appear at the very top instead of at the bottom?
Diane Poremsky says
Sure. Just change the order in the code:
If objMsg.BodyFormat <> olFormatHTML ThenobjMsg.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
If objMsg.BodyFormat <> olFormatHTML ThenobjMsg.Body = "The file(s) were saved to " & strDeletedFiles & vbCrLf & _
objMsg.Body
Else
' i think this is right - i did not test. The html p's add a little complexity.
objMsg.HTMLBody = "
The file(s) were saved to " & strDeletedFiles" & _
"
" & objMsg.HTMLBody
End If
Ben says
It worked flawlessly. Thank you very much for this. What an incredibly powerful tool!
Paul says
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.
Max says
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.
Diane Poremsky says
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?
Ram says
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.
Diane Poremsky says
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
Ram says
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?
Ram says
Is this code correct for usage - I can test this after your confirmation. Appreciate your help,
Christian says
Great resource. Thank you.
Bill says
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)
Diane Poremsky says
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"
Ned says
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
Lee says
Just to say Augusto's modification of this did exactly what I wanted - thank you! There were a couple of equals = missing from If objMsg.BodyFormat = olFormatHTML - but after adding them it worked a treat :)
Brad Walters says
Keep getting Compile Error on the following line:
If objMsg.BodyFormat olFormatHTML Then
Exact compile error is: "Expected: Then or GoTo"
And the olFormatHTML is highlighted. I am assuming that is the cause of the error but I don't know what the fix it.
I am using Outlook 2010.
Margaret says
I modified Augusto's code to:
1. Allow the user (me) to choose which folder to save the attachments to at run time and also to offer a default folder.
2. Optionally allow the user to chose different folders for different emails (but this needs work as right now the user does not get to see each subject line before choosing a folder, so I recommend either removing this option or improving it).
3. Add a new category, "Attachment," to all the emails for which attachments are removed.
4. Add some constants at the top to make future changes easier.
My code does not all fit in this comments box. Here is the first part:
Public Sub SaveAttachments()' Saves attachments in current folder. See https://www.slipstick.com/developer/code-samples/save-and-delete-attachments/#Augusto
' Modified by Margaret Blauvelt, mendoclick.com, 6/26/2017
Const cstrDefaultAttachmentsSubfolder = "DataOutlookExtractionsAttachments"
Const cintMyDocuments = 16
Const cstrAttachCategory = "Attachment"
Dim objOL As Outlook.Application
Dim pobjMsg As Outlook.MailItem 'Object
Dim objSelection As Outlook.Selection
Dim strMyDocs As String
Dim strFolderPath As String
Dim strAlternateAttachmentsFolder As String
Dim booSaveMultiplePlaces As Boolean
Dim strCats As String
' We will add a category to each email for which attachment(s) were saved and deleted.
' Also make sure that category already exists in Outlook's categories collection.
Call AddCategoryToCategories(cstrAttachCategory)
' Get the path to your My Documents folder
strMyDocs = CreateObject("WScript.Shell").SpecialFolders(cintMyDocuments)
On Error Resume Next
' Ask user if wants to save the attachments all to the same folder.
Select Case MsgBox("Do you want to save to more than one folder", vbYesNoCancel, "Multiple Folders or Just One?")
Case vbCancel
Exit Sub
Case vbYes
booSaveMultiplePlaces = True
Case Else
booSaveMultiplePlaces = False
End Select
Parker says
Hi Margaret,
you said your code does not all fit in the comments box. Is the rest of this code somewhere? It looks really good.
Dan E says
Disregard my previous question, I figured out how to change the path of the folder the file saves at. My new question is how can I make the folder path a clickable hyperlink?
Diane Poremsky says
For HTML, you'd use this url format: file://server/folder/file.ext
to hyperlink html, use
strDeletedFiles = strDeletedFiles & "
" & "" & strFile & ""
Kent S says
This code is great and will save me a lot of time. Could you expand on your hyperlinking reply; I don't quite follow on what needs to change in Augusto's version. Thank you!
Diane Poremsky says
You'll need to build the link - and uncomment the code that writes it to the message body.
hmm. It looks like the code is messed up -
This would create the html link:
strDeletedFiles = strDeletedFiles & "
" & "" & strFile & ""
(I fixed the code. )
Dan E says
Hi Diane,
I am trying to use the Augusto's Modification but am having an issue. I plan on using this code to run on a public folder that my office uses, so the files need to be accessible for the entire office. I need to modify the code so I can save the attachments automatically on the shared drive instead of in My Documents. The path location will not change so I do not want to have to select a folder every time, I just want to be able to set a direct path inside the code itself. Any assistance with doing this would be greatly appreciated!
Diane Poremsky says
It might work best if the drive is mapped so you can use a drive letter because outlook can be slow saving to a network location, but all you need to do is change the path here:
strFolderpath = strFolderpath & "\OLAttachments\"
use strFolderpath = "H:\folder\subfolder\" or strFolderpath = "\\servernamae\folder\"
Max says
Hi,
I have "Compile error: Syntax error" once I click Run. I have Windows 10 Pro and Outlook 2016. I enabled all macros and created OLAttachments folder. After pasting the code into VB editor I have multiple red lines as I understand implying the problem.
Please help me to solve the issue.
Thank you.
-Max
Diane Poremsky says
The problem is with the red lines - red = bad. Either the code picked up something goofy in the copy and paste or it's in the wrong place in the module. This isn't an auto-macro, so it's more likely the copy and paste.
Which of the macros are you using?
Jay says
Very useful!
Had to fix a few things:
- the 'specialfolders' path didn't work (Win 7) - probably because it is a protected folder. Instead I hard-coded the folderpath (only in the second sub - it is not needed in the first sub (which calls the 2nd one)
- strDeletedFiles was not filled, so no string was added to the message
You can find the updated code here (I commented out the original lines - just in case): https://codepaste.net/xynarh
Diane Poremsky says
Specialfolders should definitely work with Windows 7 - it's supported in all versions.
Martin says
Hi, great code. I am a novice in VBA.. I need some help.
What I want to add / change to your code: save all attachments from specific folder (like Inboxtest ) only with extension ".gpg"
Can you help me?
Thank You.
Martin
Diane Poremsky says
You need to add an if statment.
For i = lngCount To 1 Step -1
strFile = objAttachments.Item(i).FileName
' This code looks at the last 4 characters in a filename
sFileType = LCase$(Right$(strFile, 4))
if sFileType = ".gpg" then
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
-- snip--
Martin says
Thank you for reply but can you explaine how to add this "if statement" (i have compile errors) to your code?
Another question: where is defined path to the subfolder in Inbox where is emails with specific extensions? I have a rule that move every email with extension .gpg to this subfolder.
Thank you again!
Martin
Diane Poremsky says
the code replaces the block that begins and ends with these lines:
For i = lngCount To 1 Step -1
strFile = strFolderpath & strFile
Martin says
How can i add an if statement to you code? i have some compile errors... i am new in VBA..
i need define subfolder in Inbox from where all attachements have been saved (only with extension .gpg)
Thank you.
Martin
Diane Poremsky says
The macro as written works on any folder - you just need to select the messages. It can be converted to run on all messages in a selected folder or on all messages in a specific folder - these are the lines that tell it what folder and messages to use:
Set objSelection = objOL.ActiveExplorer.Selection
For Each objMsg In objSelection
You'd use this for all items in a specific folder
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Set objFolder = Session.GetDefaultFolder(olFolderInbox).Folders("foldername")
Set objItems = objFolder.Items
For Each objMsg In objItems
more info at https://www.slipstick.com/developer/code-samples/working-items-folder-selected-items/
Martin says
Thank You,
but where in the code is defined specific folder from where i need save all ".gpg" attachements? I have one subfolder in Inbox where is the messages with this extension..
Diane Poremsky says
This: For Each objMsg In objSelection tells it to work off the selected message. The last macro on page 3 works on all messages in the selected folder. It's also possible to hard code a specific folder - Set objFolder = Session.GetDefaultFolder(olFolderInbox).Folders("subfolder") would apply to message in a subfolder named 'subfolder' of the inbox.
https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/ has more information.
Martin says
I have now this:
DIM***
' Get the path to your My Documents folder
strFolderpath = "C:*****"
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
'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
sFileType = LCase$(Right$(strFile, 4))
If sFileType = ".gpg" Then
' Combine with the path to the Temp folder.
strFile = strFolderpath & objMsg.SenderName & "." & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile
End If
' 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 & ""
Else
strDeletedFiles = strDeletedFiles & "" & "<a href='file://" & _
but this macro save all attachements.. not only with .gpg extension...
Diane Poremsky says
Sorry I missed this earlier. You have the Save outside of the If block - anything you need to do to the message identified by the If needs to be inside the IF -
If sFileType = ".gpg" Then
' Combine with the path to the Temp folder.
strFile = strFolderpath & objMsg.SenderName & "." & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile
objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment.
objAttachments.Item(i).Delete
End If
Nick from London says
Just wanted to thank you for the code. Very useful. Adjusted it to leave original message unaltered. I use Windows Folder Browser to set save location, as we save attachments by project.
D Poremsky says
BReight before that line add either
debug.print strFile
or
msgbox strfile
The first writes the path to the immediate window, the second pops up a dialog containing the file path. Either way, verify the path it is trying to use exists.
Robert Haages says
Hi Diane, using Augusto's code, how would i add the functionality to check for a filesize of say greater than >5 or 10KB and then save all those items? I've seen an example in one of your earlier posts, but i'm unsure of where to put it in the code. My earlier attempts have resulted in a failure. Thanks ahead!
D Poremsky says
Which code sample are you using? I tested it with the first code and its working correctly here - the files are saves as msg files.
What version of Windows do you use? Are you showing file extensions?
D Poremsky says
You'll need to check for mailitem type and skip if not mail items.
Although not the best solution, you could change this
Dim objMsg As Outlook.MailItem 'Object
to
Dim objMsg As Object
the correct solution is to check for the item type - this is one way to do that;
If TypeOf objMsg Is Outlook.MailItem Then
' continue with the macro
End If
D Poremsky says
The last macro on page 3: http://www.outlook-tips.net/code-samples/save-and-delete-attachments/3/
Deletes all attachments on messages in the selected folder. Select the Sent folder and run it.
Ve Kris says
Dear All,
Thanks for this script but i am facing a issue using this script where i would need your help.
Attached this script Run as script rule and the rule is created as Client only rule. Which is supposed to run on a specific email id when the email arrives.But i see this script is not getting executed via the rule when email reaches the mailbox. Any help is appreciated.
D Poremsky says
What changes did you make when you converted it to work in a run-a-script rule? At minimum you need to remove the loop - For Each objMsg In Mail.Items and Next lines need to go.
Ve Kris says
Hello Poremsky,
Thanks for responding.
I managed to fix the issue and it seems due to the fact the changes i made was not saved properly.
wschloss says
This is WAY cool. I downloaded it, tweaked, tested (step mode), and ran against 9 years of email, all in about an hour, and I can barely program! Thank you SO much!
Jason Levine says
I have a script that moves any message with an attachment to a user-selected folder, and the script moves not only attachments listed on the attachment line but also embedded or inline attachments, like signatures, or pasted in graphics. I would like to be able to eliminate these embedded attachments and only move the messages with the traditional attachments. I'm using Outlook 2010 and haven't found a good way to do this yet and any advice or direction would be appreciated.
Diane Poremsky says
Short version: you didn't find a way because their is no way to differentiate because attachments and embedded. However, there are two things you might be able to do: check attachment size and only move larger attachments. If the attachments you need to move are large this will work great - typical signature graphics are under 5 or 10 KB. Use a value high enough to get your attachments and skip most other attachments. Other option is to look at filename. If you only need to move pdf, you can see if the attachment filename ends in pdf.
check attachment names
check attachment size example
steve tatum says
Thank you so much Diane! The changes you made work as expected...
steve tatum says
Hey Diane, have you had a chance to look at this yet?
Diane Poremsky says
I added a new version to page 3 - it will work on the selected folder.
steve says
Thanks Diane, sorry to bother you on your vacation. I did try the site you mentioned and found some code that will save outlook messages in a folder on the hard drive. This seems close to what I need but not quite. I only want to move the attachments of each message, not the entire message itself. Still, this may work with some tweaking. Maybe you could look at it to see what you think? I found it under "save all messages to hard drive using vba".
Diane Poremsky says
I'll take a look at it and see what needs changed.
steve says
Hello, first off...love this code! Thanks for posting. My issue is probably a simple one but I am not familar with Outlook coding enough to figure it out. I would like to modify this line "Set objSelection = objOL.ActiveExplorer.Selection" of the code so that I do not actually have to select all of the messages in a folder. I would like for the code to select all of the messages in a folder that I have selected and then proceed with moving the attachments.
Diane Poremsky says
That's not hard to do - i might have a sample at slipstick.com that does that, if not I will update this code so it does. I'm on vacation right now, so give me a few days and don't hesitate to remind me if I don't post something early next week.
Deepak says
This is a brilliant script - I used it with Outlook 2013 - no issues
Safwat Ammar says
Thank you so much, it is very helpful
Johan AAnscharius says
Hi Kirk, Before deleting the attachment file, there should be the following check:
Set FS = CreateObject("Scripting.FileSystemObject")
if not FS.fileexists (strfile) then msgbox("OOps, could not save the file"): end
That way you are sure the file is saved before deleting it.
Kirk says
p.s. the brackets (greater-than, less-than) have been stripped from comment input form
Diane Poremsky says
That's a wordpress bug (wordpress says its a feature)- wordpress thinks the brackets are for html. Hopefully it will be easier to read as code - i had to comment mark the blank lines to make it work for the entire code. :(
I did a quickie scan and don't see any obvious missing brackets. Let me know if they are any that need fixed.
Kirk says
Well I used this code from page 3 along with code from http://social.msdn.microsoft.com/Forums/en-US/isvvba/thread/bbe6e55c-c52b-482b-8d99-14e080bbcdd5/ to save attachments I get and unzip them using an Outlook Rule trigger...
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
'
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Dim strFileZ As Variant
Dim StrFolderpathZ As Variant
'
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
'
On Error Resume Next
'
' Set the Attachment folder.
strFolderpath = strFolderpath & "pcap"
StrFolderpathZ = strFolderpath 'pass it to unzip object variable
'
' 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 & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile
'
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
strFileZ = strFile 'pass it on to the unzip variable
'
' 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 & "" & strFile & ""
Else
strDeletedFiles = strDeletedFiles & "" & "" & 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
'
' Unzip the attachment if it is compressed as zip file
If (Right(strFile, 3) = "zip") Then
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(StrFolderpathZ).CopyHere oApp.NameSpace(strFileZ).Items
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
End If
'
ExitSub:
'
Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub
Ford says
Thank you for the great and very useful example. With a little effort, it does a great job and has taught me a great deal about macros and VBA within Outlook.
On the question (and suggestion) for skipping embedded images (as in company logos), I thought of a couple of other methods, but am not adept enough to make it work. Is there perhaps a way to examine a property of the attachment to determine it is embedded within the body?
Another thought for me was to examine the attachment file size and skip it if it was less than,,, say, 15KB.
And yet another thought was to check the file extension for being a .png or .jpg. I have seen these embedded logos with various names, so checking for a specific name as you suggested is not effective in all cases.
Thank you again for the really great lessons.
Diane Poremsky says
Checking for the file extension is probably the best option. I didn't suggest it because if you get jpg or png you want saved, it won't work.
Andy says
also, how do I change the path so saves to eg "C:Attachments" (substituting that into the code doesnt seem to have worked)
thanks
Diane Poremsky says
Where did you stick it in?
This line uses one of the special windows folders (My Docs):
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
And this sets the subfolder.
strFolderpath = strFolderpath & "OLAttachments"
Remove the first strFolderpath line and replace with second with this and it should work.
strFolderpath = "C:Attachments"
Andy says
Thanks Diane, I get an error when I add 'Set objSelection = objOL.ActiveExplorer.Selection ' into the code...where should this go?
Diane Poremsky says
It's already in the code - you don't need to add it. It's the 3rd line in the code.
Andy says
hello, thanks for the code...can this work on specific folders rather than all folders/inbox
Diane Poremsky says
Yes, This line: Set objSelection = objOL.ActiveExplorer.Selection tells it to work with the selected messages. They can be in any folder.
Anthony Shelton says
I love this script, however I am running into one major issue.
My companies signature uses .png and .jpeg images. These objects are recognized as "attachments" by this script, and are stripped and stored with the legitimate attachments.
Is there any way I could alter this script to ignore these signature elements, and only apply to mail message attachments directly under the Sent: and To: columns?
Diane Poremsky says
You can't tell it to skip signatures - it doesn't identify an attachment as part of a signature.
If the attachment name is always the same "company-logo.png" you can could use an If statement to skip them. If you want to skip all png or jpg attachments, you could do that too. '
It would be something like this:
strFile = objAttachments.Item(i).FileName
If strfile <> "company-logo.png" then
strFile = strFolderpath & strFile
objAttachments.Item(i).SaveAsFile strFile
else
strfile = ""
End if
objAttachments.Item(i).Delete
asdfasdfasdf says
dont use this script as it will overwrite any attachments with the same name and then delete them making them unrecoverable. Very embarassing situation for me thanks to this.
Diane Poremsky says
Did you read the note in the yellow block at the top? Augusto shared code with us that saves the items with a name format of SenderName.ReceivedDate.filename.ext to prevent this problem.
Aaron says
I can't win. Oh well... I'm building a file tag around strFile so Outlook will link it even in a text message.
Aaron says
Haha, even my explanation didn't work properly. To be clear it's:
strDeletedFiles = strDeletedFiles & vbCrLf & "" & strFile & ""
Aaron says
Thank you for the code example! I think I've worked through the difficulties presented by the website here not displaying all of the actual code correctly and am down to one problem with building strDeletedFiles for non-HTML messages. For some reason it ignores vbCrLf and just smushes all my links together in a single line.
This is what I have:
strDeletedFiles = strDeletedFiles & vbCrLf & ""
(not sure the end of this will display properly but basically I am adding on a
I've tried vbNewLine as well, and have tried just inserting Chr(10) & Chr (13). Any ideas?
Interestingly, when I build objMsg.Body and use vbCrLf it works fine
Jen says
Me again. It didn't paste the second line that is giving me an error:
strFile & "'>" & strFile & ""
Jen says
Hello, all.
I'm having trouble with the following two lines. VBA wants an expression, but in all of my searching, I have not found a fix. Any help is appreciated!
strDeletedFiles = strDeletedFiles & "" & "" & strFile & ""
Diane Poremsky says
Make sure the quotes are not "smart quotes" - it pasted fine for me just now so that should be ok for you.
Backspace that line to make one line with the previous line - so instead of
[stuff] & _
strFile [stuff]
it will be [stuff] & strFile [stuff]
Pedro M. Lledó says
Hi all,
I'm trying to modify Augusto's script in order to be able to select a folder to save the attachments, instead of saving it to the My DocumentsOLAttachments.
I'm trying the FolderBrowserDialog object, but I got an error about user-defined type not defined, when compiling the visualbasic code. I'm trying to link the right Library in Tools-->References, but no success.
I'm using Outlook 2007 on Win7
What I'm missing?
Please advice and thanks a lot for your help in advance.
Kindest,
Pedro
Diane Poremsky says
Which library are you referencing?
Diane Poremsky says
@nick what happens when you try? Because the code adds file names to strFolderpath, it might work better to make a new string variable that is used only for the folder path:
dim strFolderOnlypath as string
strFolderOnlypath = strFolderpath & "OLAttachments"
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = objMsg.Body & vbCrLf & _
"The file(s) were saved to " & strFolderOnlypath
Else
objMsg.HTMLBody = objMsg.HTMLBody & "
" & _
"The file(s) were saved to " & strFolderOnlypath & "
"
End If
Nick says
This macro is great! It is a feature that should be built-in! Especially useful for those of us who have limits on mailbag size.
I'd like to add a link to the OLAttachments folder in the message.
I can make it work with Rich Text but not with HTML messages.
I just replace the "strDeletedFiles" with "strFolderpath" but it doesn't work.
Ray says
Forgot to include that i use Outlook 2003 on Win XP.
Ray says
Hello,
I receive emails that contain .pdf, .txt., .doc and other types of attachments. I would be very grateful if someone could show me how to modify the above code so that I can remove and save all attachments but leave any pdf files in the emails if they exist.
Nick says
Hi - thanks for all the work on this, it's just great. However, I would prefer to replace the attachments with a text file indicating the location of the saved attachments, rather than adding text to the end of the message body. Does anyone know how to do this?
Nick says
Hello again - figured that out by reviewing other code online - seems it just needed a not equals sign, to read “If objMsg.BodyFormat olFormatHTML Then”. I wonder why it works without for some people.
Nick says
Hi, this looks great - thanks. Unfortunately, I get a Compile error: Syntax error when I try to run it. The code breaks at "If objMsg.BodyFormat olFormatHTML Then" - it seems to want a Then or GoTo immedaiately after "If objMsg.BodyFormat". Any thoughts?
As a possible enhancement, would it be straightforward to remove the attachments and instead of adding text to the email, replace the attachments with a text file listing the attachments and their new locations or even a file with active links to the removed files?
Tony says
Thanks for the interesting information. However, I was wondering if anyone knows how to alter the Attachment Drag & Drop functionality with resepct to copying an attached file from Outlook to a Windows Explorer folder.
When I drag an attachment to an Explorer folder, the date modified date/timestamp becomes "now" (current time), not the original attachement's date modified. Is there a way to preserve the original timestamp when dragging attachements out of Outlook?
Thanks in advance.
Diane Poremsky says
To the best of my knowledge, no you can't change the behavior. It's always been a bit goofy, with the Window Explorer date taking Outlook's time stamps if the message was received within a certain time period (approx 2 weeks prior). Augusto's code sample will add the received to the filename field - not quite the same, but it can help. I'll see if i can put together some VBA that will set the Windows time stamp using the received time.
Augusto Papagno says
Hello:
I did some modifications on Frank's code, in order to avoid file overwritting when the attachment name is the same as an existing one (i.e. details.txt on a return receipt email). Now, the attachemnts are saved in the format "SenderName.ReceivedDate.filename.ext" and then the attachment is deleted from the orinal email.
Here is the 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 & vbCrLf & ""
Else
strDeletedFiles = strDeletedFiles & "" & "" & 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
Chris says
I wanted to add to my above question # 2 that I used Frank's modified code that is supposed to break it into a single call for each mail item so you can use it with a rule to filter incoming mail but still did not understand how to get the rules to work with that code modification.
Chris says
I have two questions:
Question 1 -
This code worked great, How would I modify this code so that it would save the email message to disk in an outlook message file format. The email messages that I am wanting to process do not have attachments and would like to know how to modify this code to save it to disk. Now I have to manually do a "File Save AS" and know I can get VB to do it for me automatically.
This code worked so well for attachments that I know it would work good for just saving the msg to file.
Question 2 -
I am trying to make a "rule" in my outlook to process incoming emails with a certain subject line and then call the SaveAttachments VB code to run. I cant find a way to call this vb code macro. I can run the macro manually on an email message and it works just fine but can't see how to have a rule call this macro and run it automatically.
rakesh seebaruth says
Hi ,
i have a master copy file named(master copy.xls).whatever name is given in cell "e5" is saved as by that name.(e.g if cell e5 is tom) then the file will be saved as tom.xls. My master copy file will remained unchanged. My problem is that when i attached the tom.xls file thru outlook .the latter does not send the file tom.xls but it send the master copy.xls file .Plz help My VBA Codes are below
Sub save()
mydrive = "C:"
mydir = "excel"
myname = Sheets("sheet1").Range("e5")
Application.DisplayAlerts = False
ThisWorkbook.saveas Filename:=mydrive & "" & mydir & "" & myname & ".xls"
Application.DisplayAlerts = True
End Sub
Sub Mail_Workbook_1()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = " aa@yahoo.com"
.CC = ""
.BCC = ""
.Subject = Range("e5")
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
rakesh seebaruth is offline Reply With Quote
John Fitzgerald says
Awesome! Thanks. Anyone know how to keep the paperclip icon?
Also, I had to comment out the last End If for some reason.
Diane Poremsky says
You can't keep the paperclip unless there is an attachment - you can remove the line from the code that deletes the attachment or rework it to add a small attachment to the message.
Rob says
Wow this is great, thanks! Clear, well commented and well thought out. You're very good
Christopher W. Brown says
Thanks for the code. I tried using it a few months ago but got syntax error messages. Not a VBS guy and this is the first time I've attempted programming outlook so I put it off. I revisited it today when I had some time. Anyway, I am using Outlook 2007 on Windows 7 Pro and I had to replace all of the '&' with just the '&' and the '>' and '<' with actual > and < signs. Now it works as advertised.
The msg box didn't really look correct either. It was displaying the html text in the box. But I was able to know what it was telling me and now I've debugged and deleted the MsgBox stuff so I'm good. Thanks again for the code. Just wanted to inform those who may get the syntax error using the '&' type commands.
(Also had to Ctrl-V to paste code not Ctrl-P.)
Diane Poremsky says
Thanks for bringing the problems to my attention. I'll fix the code... again. (Code samples are the one big failing with WordPress.)
Nick says
Hi, thanks for publishing this. It would really help if the macro were able to create a subfolder for each email's attachments, labelled with the Subject of the email (truncated and cleaned of unusable characters if needed) with a _YYYY MM DD_hh mm ss suffix for date and time received. Does anyone know how to add this easily?
Thanks again.
Frank Bello says
Thanks so much for compiling this code. Quite of some help!
I 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.
[admin note: click the link to view Frank's code or open the text file linked near the top of this page.]
[code lang="vb" collapse="1"]
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 & vbCrLf & ""
Else
strDeletedFiles = strDeletedFiles & "" & "<a href='//" & _
strFile & "'>" & strFile & "</a>"
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
[/code]
kavsoo says
This code works only when the outlook is opened by the user, is there a way to make it work automatically (assuming the inbox never gets opened, and all the attachments coming to this inbox should get stored in a folder). Appreciate inputs.
Diane Poremsky says
The only way to run code on a mailbox that is never opened, is to do it on the server. Outlook (or any mail client) needs to check for new mail and download it before it can process it.
Is this an exchange mailbox? If so, a server-side event sink or, if you open the mailbox as a secondary mailbox, tweaking the macro should work.
kavsoo says
Thank you Diane for your response;
Here's my situation, this is an exchange mailbox. I'm afraid that the IT admin will allow me to set up a server-side event for a small task, so this is out of the question.
So can you explain more about "opening the mailbox as secondary and tweaking the macro"?
thanks again
James says
I have the same situation. Have you found a solution yet?
Darryl Gittins says
Lookks nice but the script fails for me with a run-time error'9', subscript out of range:
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
Diane Poremsky says
I can't repro that error - I thought maybe it was because you didn't create the olattachments folder under My Documents - but the code runs error free, it just doesn't actually save the attachments. (I am getting a block-end if error, not sure why since no one else complained.)
What version of Windows? Is Windows Scripting installed/enabled?
Mohan says
I would like to keep attachment file names in the email message whenever I remove/delete attachments from the email. This feature was there in Lotus Notes. How to get this feature in Outlook?
Thanks
Mohan
Diane Poremsky says
You need to use an addin or VBA - the code on this page does it with this line: strDeletedFiles = strDeletedFiles & "" & "" & strFile & ""
if you want just the file name and not the save path, you can edit the code to remove the parts that remember the path.
See https://www.slipstick.com/addins/attachment-management-tools-for-outlook/ for addins that will do this for you.
JonasL says
Great script, however when I mark several messages the text in each e-mail that tells you were the files were saved contains ALL files that were saved and removed, i.e. not only the attachements that were removed from that specific e-mail. Anyone else that experience this problem? Suggestions for fixing it?
Thanks!
Diane Poremsky says
It's been a long time since I wrote the code, but I think its meant for single message use. For multiple messages you need to do a loop and clear the values before moving to the next message.
With just looking at it here quickly, so I could be wrong, it might work to reset the strAttachments value or objAttachments before looping.
JonasL says
Perfect, I just resetted the strDeletedFiles after each loop and now it works like a charm.
Thanks!
Diane Poremsky says
Cool. Thanks for sharing.
Diane says
Security prompts or the message boxes telling you want is happening?
The lines of code beginning with MsgBox can be deleted - they are just there so you can see what is happening. They can be very useful for troubleshooting.
Either delete or add a ' in front of each msgbox to disable it - like this:
' MsgBox strDeletedFiles
JRM says
Any chance the code can run without prompts of any kind?
outlooktips says
Alt+F11 works with Outlook 2010 - why it didn't for you is a mystery. (Sometimes other apps interfere and hijack the shortcuts.)
Josh says
Brilliant code!!! Exactly what I was looking for. And thanks for the super easy instructions to follow. The only difference I found was that in Outlook 2010 Alt+F11 didn't work, so I just had to turn the developer toolbar on.