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

This version of the macro adds a number to the filename if the filename already exists in the folder, like this:

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

Increment files name using Rules

For a run a script version of the above macro, you need to change the macro name and remove the code that works with the selected messages.

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

 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:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

More information as well as screenshots are at How to use the VBA Editor