A visitor to our forums had a script to save attachments to his hard drive and wanted to add the attachment's modified date to the filename.
To get the modified date (or any other file property), you need to use the FileSystem Object, or FSO, to read the properties.
Instead of using the file's modified date, or if Outlook is not getting the expected modified date, you can use the email message's sent date. In many cases, the DateLastModified on the attachments will be the Sent date anyway. A macro using the SentOn field is here.
The first macro saves the attachments on selected messages and changes the names of the saved files to include the modified date. The second macro is used as the script in a rule a script rule.
The macros save the attachments to a subfolder under the user's Documents folder.
If you want to save the attachment in a folder by date, subject name, sender, etc, you would use the filescripting object to create a folder if one does not exist.
This macro saves the attachments on one or more selected messages.
Save & Rename Attachment with Subject
This macro renames the attachment as it is saved. Because it uses the message subject, we need to check for characters not supported as file system names and replace them.
We also need to get the file extension and add it to the filename. While you can use InStr to find the dot and use that to get just the last 4 or 5 characters (the dot and the extension), this sample gets the last 5. If the extension is 3 characters ( pdf, zip etc), it will include the last letter of the original file name.
Public Sub saveAttachtoDisk() Dim itm As Outlook.MailItem Dim currentExplorer As Explorer Dim Selection As Selection Dim strSubject As String, strExt As String Dim objAtt As Outlook.Attachment Dim saveFolder As String Dim enviro As String enviro = CStr(Environ("USERPROFILE")) saveFolder = enviro & "\Documents\Attachments\" Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection For Each itm In Selection For Each objAtt In itm.Attachments ' get the last 5 characters for the file extension strExt = Right(objAtt.DisplayName, 5) ' clean the subject strSubject = itm.Subject ReplaceCharsForFileName strSubject, "-" ' put the name and extension together file = saveFolder & strSubject & strExt objAtt.SaveAsFile file Next Next Set objAtt = Nothing End Sub Private Sub ReplaceCharsForFileName(sName As String, _ sChr As String _ ) sName = Replace(sName, "'", sChr) sName = Replace(sName, "*", sChr) sName = Replace(sName, "/", sChr) sName = Replace(sName, "\", sChr) sName = Replace(sName, ":", sChr) sName = Replace(sName, "?", sChr) sName = Replace(sName, Chr(34), sChr) sName = Replace(sName, "<", sChr) sName = Replace(sName, ">", sChr) sName = Replace(sName, "|", sChr) End Sub
Use in a Run a Script Rule
This script is used in a run a script rule. It adds today's date to the attachment filename.
Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem) Dim strSubject As String, strExt As String Dim objAtt As Outlook.Attachment Dim saveFolder As String Dim enviro As String enviro = CStr(Environ("USERPROFILE")) saveFolder = enviro & "\Documents\Attachments\" For Each objAtt In itm.Attachments DateFormat = Format(Date, "yyyy-mm-dd ") file = saveFolder & DateFormat & objAtt.DisplayName objAtt.SaveAsFile file Next Set objAtt = Nothing End Sub
Increment the filename
Change the string: FnName & x & fileext as needed. For example, if you want to the filenames in this format: 2015-06-12 error (2).png format, use FnName & " (" & x & ")" & fileext.
Public Sub saveAttachtoDisk() Dim itm As Outlook.MailItem Dim currentExplorer As Explorer Dim Selection As Selection Dim objAtt As Outlook.Attachment Dim saveFolder As String Dim fso As Object Dim oldName Dim file As String Dim DateFormat As String Dim newName As String Dim enviro As String enviro = CStr(Environ("USERPROFILE")) saveFolder = enviro & "\Documents\" Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection Set fso = CreateObject("Scripting.FileSystemObject") On Error Resume Next For Each itm In Selection For Each objAtt In itm.Attachments file = saveFolder & objAtt.DisplayName objAtt.SaveAsFile file 'Get the file name Set oldName = fso.GetFile(file) x = 1 Saved = False DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ") newName = DateFormat & objAtt.DisplayName 'See if file name exists If FileExist(saveFolder & newName) = False Then oldName.Name = newName GoTo NextAttach End If 'Need a new filename Count = InStrRev(newName, ".") FnName = Left(newName, Count - 1) fileext = Right(newName, Len(newName) - Count + 1) Do While Saved = False If FileExist(saveFolder & FnName & x & fileext) = False Then oldName.Name = FnName & x & fileext Saved = True Else x = x + 1 End If Loop NextAttach: Set objAtt = Nothing Next Next Set fso = Nothing End Sub Function FileExist(FilePath As String) As Boolean Dim TestStr As String Debug.Print FilePath On Error Resume Next TestStr = Dir(FilePath) On Error GoTo 0 'Determine if File exists If TestStr = "" Then FileExist = False Else FileExist = True End If End Function
How to use macros
First: You will need macro security set to low during testing.
To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.
After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.
Open the VBA Editor by pressing Alt+F11 on your keyboard.
To put the code in a module:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor
More Run a Script Samples:
- Autoaccept a Meeting Request using Rules
- Automatically Add a Category to Accepted Meetings
- Blocking Mail From New Top-Level Domains
- Convert RTF Messages to Plain Text Format
- Create a rule to delete mail after a number of days
- Create Appointment From Email Automatically
- Delegates, Meeting Requests, and Rules
- Forward meeting details to another address
- How to Change the Font used for Outlook's RSS Feeds
- How to Process Mail After Business Hours
- Keep Canceled Meetings on Outlook's Calendar
- Move messages CC'd to an address
- Open All Hyperlinks in an Outlook Email Message
- Outlook AutoReplies: One Script, Many Responses
- Outlook's Rules and Alerts: Run a Script
- Process messages received on a day of the week
- Read Outlook Messages using Plain Text
- Receive a Reminder When a Message Doesn't Arrive?
- Run a Script Rule: Change Subject then Forward Message
- Run a script rule: Reply to a message
- Run a Script Rule: Send a New Message when a Message Arrives
- Run Rules Now using a Macro
- Run-a-Script Rules Missing in Outlook
- Sort messages by Sender domain
- To create a rule with wildcards
- Use a Rule to delete older messages as new ones arrive