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:
- 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 Information
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 a Task from an Email using a Rule
- Create an Outlook Appointment from a Message
- Create Appointment From Email Automatically
- Delegates, Meeting Requests, and Rules
- Delete attachments from messages
- 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
- Macro to Print Outlook email attachments as they arrive
- 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: Autoreply using a template
- 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
- Save all incoming messages to the hard drive
- Save and Rename Outlook Email Attachments
- Save Attachments to the Hard Drive
- Save Outlook Email as a PDF
- Sort messages by Sender domain
- Talking Reminders
- To create a rule with wildcards
- Use a Macro to Copy Data in an Email to Excel
- Use a Rule to delete older messages as new ones arrive
- Use a run a script rule to mark messages read
- Use VBA to move messages with attachments
Stephen says
Hello,
Can I set the subject as below?
Attachment file name : abc
Subject : HAWB: abc PODRT
Melanie says
I just want to say thank you! This was so easy to follow and saved me a TON of manual work. Very much appreciated.
Yohann says
Hello Diane, please, do you know if there is any way to rename the attachments of an email without exporting, renaming and then importing them; that is to say renaming them directly into the email?
Thank you in advance.
Yohann
Diane Poremsky says
The attachment needs to be saved to a temp folder to rename it - but a macro can save it, rename it and put it back. You need a dialog box asking for the new name or use a scheme to rename it automatically (like add the date or your initials to the existing name).
Diane Poremsky says
Here is a macro to change the attachment name in either incoming or when composing a message.
https://www.slipstick.com/developer/code-samples/rename-outlook-attachments/
Yohann says
Many thanks Diane.
Sathishkumar Umashankar says
Hi Team, Currently I am looking for a macro to save the attachments to a folder and rename the file names by adding prefix (FROM,SUBJECT, RECEIVED DATE AND TIMING & ONE MORE COLUMN WHICH IS REMARKS newly inserted in outlook which needs to be counted in the filename as prefix of the file name.
Diane Poremsky says
the default fields are no problem - you will definitely need to run it through an illegal character function to remove characters not supported in file names.
For a custom field, you need to use a userproperties field. An example is here:
https://www.slipstick.com/tutorial/create-a-custom-field-to-mark-messages/#macro
Adrian says
If I am running following Macro as rule in Outlook it works fine:
Public Sub SaveAttachmentsToDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\A_DANO\TEST\"
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
but if I am runnign following Marco in Outlook - to save file and rename based on Subject it does nothing - no error - no files saved at all
Public Sub SaveAttachmentsToDisk(itm As Outlook.MailItem)
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
saveFolder = "C:\TEST\"
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)
End Sub
Can you help please
Thnak you
Diane Poremsky says
Is the name correct? Right after file = saveFolder & strSubject & strExt, add msgbox file and test it. Is the filename the expected name?
(I'll test it here in a bit.)
Brandy says
The problem that I am having is it gives me a run-time error that it cannot find the file i want the attachment saved in. I have to hit "end" every time I get a fax/email and it then pushes the attachment to the folder.
But I have to hit end every time. If I hit debug, it says it's caught up on...
objAtt.SaveAsFile saveFolder _
& Format(itm.ReceivedTime, "mmdd~hhmmss~") _
& Mid(itm.Subject, 11, 12) _
& Right(objAtt.FileName, 4)
I am lost and have been trying to fix this since we upgraded our Outlook.
Diane Poremsky says
Add debug.print saveFolder _
& Format(itm.ReceivedTime, "mmdd~hhmmss~") _
& Mid(itm.Subject, 11, 12) _
& Right(objAtt.FileName, 4)
right before the saveasfile line - then check the immediate window (turn it on from the View menu) - is the path correct?
Brandy says
Still makes me hit end. It pushes the attachment into the folder before I do so, but it won't move on in Outlook until I either hit end or debug.
The path is correct. I am having it save attachments to a shared drive so that my department will have access to the faxes if I'm not in the office. It has been working fine for a few years until we upgraded to Office365 recently. Now, this is happening and I have queries in Access that quit working.
Here is the entire code (before the debug you suggested), maybe you can see something I can't. Any help is very much appreciated!!
Public Sub Save_Fax_to_W(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "W:\FAXES - Not Logged\"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder _
& Format(itm.ReceivedTime, "mmdd~hhmmss~") _
& Mid(itm.Subject, 11, 12) _
& Right(objAtt.FileName, 4)
' subject: Fax from [765-281-3436]...
' filename: 0307~163645~765-281-3436.pdf
Set objAtt = Nothing
Next
End Sub
Diane Poremsky says
Does it work as expected if you use a local drive? i know there can be issues with network drives.
Brian says
Clarification: When two conditions are met (Sender and Attachment name), I'd like the saved attachment to be renamed 'XYZ A great site 08-11-2017 and saved into a dynamic path.
Sorry about that.
Diane Poremsky says
once you get the values you can use them in any way you want -
filename = attachment.name & strsubject & format(Date, "mm-dd-yyyy") & ".xlxs"
(you may need to strip the extension from the attachment.name first - again, not hard to do - strname = left(attachment.name, 5)
Brian says
Thank you for the response! I'm still struggling through this. I can't get either lchar or regex to work at all, so I have the full subject line included on the saved file.
Also, with the script below there are 3 additional .bin excel files that are created each run.
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 strsubject As String
Dim lchar As String
strsubject = ActiveExplorer.Selection.Item(1).Subject
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "DesktopTest"
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)
'Can not get any variation to work, or with regex
If lchar = InStr(1, strsubject, "{") Then
strsubject = Right(strsubject, Len(strsubject) - lchar)
End If
'somehow now creates 3 additional unwanted Excel files
newName = Left(oldName.Name, 19) & " " & strsubject & Format(Now, " mm-dd-yyyy") & ".xlsx"
oldName.Name = newName
Next
Next
Set objAtt = Nothing
Set fso = Nothing
End Sub
Diane Poremsky says
Any error messages?
The lchar stuff may need to be tweaked - i didn't test it. Will try to test it over the weekend.
Diane Poremsky says
oh, i see the problem - it's not an if.
get the position of the ( using this:
lchar = InStr(1, strsubject, "{")
then get the right most part of the subject by subtracting the position from the length of the entire subject:
strsubject = Right(strsubject, Len(strsubject) - lchar)
This might need to be tweaked - Len(strsubject) - lchar - but you won't know until you test it. if its way off, try
lchar = InStrRev(1, strsubject, "{")
(InstrRev counts from the right.)
Brian says
Works exactly as I hoped for, thank you! Added a kill command to get rid of the additional files that were being created.
Thanks again!
Brian says
Hi Diane,
Your coding is beautiful. Thank you for sharing. I'm trying to use the above with a twist. I'd like to take the attachment name and combine with all words to the right of an illegal character from the subject line (which the length of words will vary), and add the date. And then save to a daily folder.
Ex:
From: ABC
Subject: this is{A great site
Attachment: ZYZ.xlsx
When two conditions are met (Sender and Attachment name), I'd like the saved attachment to be renamed 'ABC A great site 08-11-2017 and saved into a dynamic path. The path I use in Excel VBA is Desktop" & "" & Year(Now) & "" & MonthName(Month(Now), True) & "" & Month(Now) & Day(Now) & "" & Range("A11").Text.
Thanks for any help you can provide.
Diane Poremsky says
You'll need to use instr function to get the location of the character (assume its the same character every time) then right function to get the text - or you could use regex to get the string to the right - this would allow you to easily look for different characters.
lChar = instr(1,item.subject, "(")
then
strsubject = right(item.subject, len(item.subject) - lChar)
for the date, you can use what you are using now or format(Date, "yyyymmmdd") ' 2017Aug16
John Barnes says
Hi All,
I'm using your below script
Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem)
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 & "Documentstest"
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each objAtt In itm.Attachments
file = saveFolder & objAtt.DisplayName
objAtt.SaveAsFile file
Set oldName = fso.GetFile(file)
DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
newName = DateFormat & objAtt.DisplayName
oldName.Name = newName
Set objAtt = Nothing
Next
Set fso = Nothing
End Sub
What I will like to do is have it modified to save the attachment as a specific
filename of something like abc.xls
I don't want anything else but that. Can someone here help me modify the
script?
Thans
Diane Poremsky says
You'd use something like this - if the extension is repeated, remove it from the macro and just use the file name.
Set oldName = fso.GetFile(file)
newName = "abc.xls"
oldName.Name = newName
Matthew Schlaff says
Thank you for this. This saved me a lot of time. Just a few questions:
Why do you have
Set objAtt = Nothingat the end of the inner for loop? Is it just to clear out the memory each time?
How would you modify this to run all attachments in an email of a specific folder in outlook? Thanks again.
Diane Poremsky says
it shouldn't be in the loop - because that resets the count. It should be at the end.
Elene says
Hi Diane,
I was able to run below VBA script in Outlook 2010 rule previously to save the attachment to my hard disk. After upgrade to Outlook 2016, it does not work anymore. Not sure if you have any idea what goes wrong?
Thanks for your help in advance!
VBA Script :
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:temp"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub
Diane Poremsky says
The macro will work in 2016. Did you check the macro security setting? Are you signing the macros so you can keep security set higher? If so, remove the signature and resign it.
simon says
Hi Dianne,
I have a working VBA code that allows for outlook to move files in different network drives to be moved from one folder to another. The code is below.
I am keen to be able to move some of these files to a sharepoint site (we actaully use a platform called OpenText but is similar to sharepoint). Essentially it appears to be a cloud type platform.... i can drag and drop files directly, but cant understand how to amend the code below to save direct from outlook to this network drive.
So in the below example the ToPath should be http:// or network drive listed as //inflo .....
Thanks, Simon
`Sub Mailcopy22()
''\msg As Outlook.MailItem
''\This example move the folder from FromPath to ToPath.
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim enviro As String
enviro = CStr(Environ("PICKARDS"))
FromPath = "O:BROSewerage TransferOperational & Process SupportTeam ProcessesMWC Induction Process Improvement7 From Path" '<< Change
ToPath = "O:BROSewerage TransferOperational & Process SupportTeam ProcessesMWC Induction Process Improvement8 To Path" '''
If Right(FromPath, 1) = "" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub'
Diane Poremsky says
You'll use a network path - \\server-name\path\to\folder - if the folder is not synced or mapped to your local drive.
Andrew says
I have this code which processes manually selected mails, but I need to add automatic processing of attachments in this shared inbox, I will fire the macro from other posts with the logincomplete event.
code snippet;
Set currentExplorer = Application.ActiveExplorerSet Selection = currentExplorer.Selection
Set fso = CreateObject("Scripting.FileSystemObject")
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)
Yesterday = oldName.DateLastModified
attachment treatment, renanimg etc continues here...
Diane Poremsky says
To run it on any folder other than the default inbox, you need to use an ItemAdd macro.
https://www.slipstick.com/developer/itemadd-macro/ - you need the first two macros on the page, plus the instructions to watch a different folder.
Put the code you posted in the itemadd macro and change these lines:
For Each itm In Selection - delete this line
For Each objAtt In itm.Attachments - change itm to item
Matt says
Sorry I meant to ask how I can use an inputbox to define the FOLDER into which the file is saved.
Matt says
Hi Diane
How can I add an inputbox in this macro to define the FILE into which the attachment is saved after the rule is triggered? Thanks!
Diane Poremsky says
You can, although it could get annoying. If the folders use a pattern that can be programed, it would be easier to let the macro do it.
Matt says
Hi Diane
I would like to save based on the subject line but I need it to ignore text and only save based on a 7 digit number in the subject line and save to preexisting folders with that same 7 digit number. is that doable?
Thanks!
Diane Poremsky says
It is doable. You'll use an if statement that checks for a 7 digit number.
if this doesn't work, then you'll need to use regex:
If olMailItem.Subject Like "*???????*" = True then
...
leyya says
Hi Diane. I am totally new to VBA. i desperately need your help.
Which part of the script should i alter if i want to change the attachment name to subject name?
The subject does contain illegal characters such as [ ] and >.
I only want the subject name. not the date and others. i try to put as itm.Subject
but it doesn't seem to work.
I tried other codes also, but it still doesn't work. It still download as the attachment name. Can you pls help.
Diane Poremsky says
itm.subject will work but you need to strip illegal characters. I have a function to remove illegal characters at the end of the first macro at https://www.slipstick.com/developer/code-samples/save-messages-and-attachments-in-a-new-folder/
' remove illegal characters and shorten name
StrName = StripIllegalChar(itm.Subject)
StrName = Left(StrName, 40)
then use
newName = StrName
Matthew Schlaff says
I had tried doing this but my emails subject had illegal chars so I took it out. I'll have to add it back now. Thanks.
Diane Poremsky says
if the subject has characters that are not allowed as file names, they need to be stripped.
liya says
hi Diane,
is it possible to rename the attachment to the email's subject name?
example the file name is 12302016-1959. and i want to autodownload the attachment and rename to the subject name. is it possible?
Diane Poremsky says
you would use the .subject field when you rename it.
newName = itm.subject
you'll probably need to grab the file extension - that would be right(objAtt.DisplayName,5)
newName = itm.subject & right(objAtt.DisplayName,5) (assuming dot and 4 character extension - if the extension length varies, you'll need to get the position of the dot to grab the extension)
Mehmet Erkmen says
Dear Diane,
Thank you for sharing these priceless codes. Unfortunately, I could not make it work the "If the file exists in the destination folder, then add incremential number to the filename" function
It seems the fso is not working even I've checked Tools - References - Microsoft Scripting Runtime. I've copied your code and paste, and only changed the savefolder path. Do you have any suggestion? I've checked several websites but could not manage.
thanks in advance,
Best regards.
Diane Poremsky says
what happens when you try it? Do you get any error messages?
Kim says
I'm volunteering at a nonprofit and digitizing their files, basically scanning and saving the documents under the member name and number. They would like all the files names to be standardized. Someone working before on this project, titled them "Last Name, First Name 000Number" They don't want the comma in there or the zeros before the number. Is there an easy way to take out the comma and zeros in the files names rather than doing it one by one?
Diane Poremsky says
sorry I missed this earlier - depending on your situation, a bulk rename utility might be easiest. I use this one: https://www.bulkrenameutility.co.uk/Main_Intro.php
Should also be able ot do it using a VBScript and possibly a batch file.
If the attachments are arriving by email and you need to save them without the comma, you can use the replace function:
newName = replace(objAtt.DisplayName, ",","")
oldName.Name = newName
Mayank says
Hi Diane,
On daily basis we receives multiple emails from our customers with different attachments, which till now we are manually saving them to different locations in the shared drive. Can you help me and share any Outlook macro that I can use to automatically save the .xls files / pdf files in shared folder directly from emails ?
Diane Poremsky says
Are you saving to one folder or does it vary with each message?
At the very basic, all you need to do to use these macros is to change the path in this line:
saveFolder = enviro & "\Documents\test\"
to
saveFolder = "\\networkservcer\foldername\subfolder\"
Mayank says
Hi Diane,
Thanks a lot for your quick reply.
We receives different attachments and saving them to different folders located in shared drive. Each folder is named after customers name, so for example if I receives an attachment for ABC corp, I need to manually save the attachment to ABC corp folder in shared drive. I have very less idea about Macros and would appreciate if you can help me to create a macro for this.
Diane Poremsky says
You'll need to get the sender's name itm.sendername and use that in the path. The macro at https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/ has an example that saves to different files. A text file containing a working sample from that page is here - https://www.slipstick.com/macros/save-in-sender-folder.txt
Mayank says
It vary folder to folder with each message. Additionally, I tried changing the path but seems not working for me... any options ?
Diane Poremsky says
Try the macro at https://www.slipstick.com/macros/save-in-sender-folder.txt
Michelle says
I using your code above but an on an exchange server so it won't give me the email addresses with itm.SenderEmailAddress. What could I use to have the file name be the senders email address from an exchange server? Thanks!
Diane Poremsky says
you need to get the smtp address using propertyaccessor - https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/ -
Address = pa.GetProperty(PR_SMTP_ADDRESS)
I have an example of this method on this page - https://www.slipstick.com/how-to-outlook/prevent-sending-messages-to-wrong-email-address/#internal (both the macro before this bookmark and after get the smtp)
alyshalynn says
I'd like to have multiple scripts that each run with separate rules, e.g. - where emails from different senders would then have the attachments saved in separate folders.
I'm having a problem when I use this kind of code in separate modules, where each subsequent module won't work, and the rules associates with them return the error 'The Script "" doesn't exist'
Is there a better way to save these as separate scripts? Should they all go into ThisOutlookSession instead of separate modules, or some other workaround I'm not thinking of. If so, how does this affect the code?
Diane Poremsky says
Run a scripts can be in the same module, preferably not in ThisOutlookSession. If you are using stub scripts in the rule and passing values to the (shared) main macro, they should all be in the same module. You could use 1 rule and one script - select case statements set the folders.
The script doesn't exist error means the rule can't find the macro.
alyshalynn says
First off, thanks for such a quick reply!
Secondly, I wish I were that advanced, but I'm not sure I'm there yet def willing to learn though.
I modified your code to something I think should work, but still isn't quite there. I'm not sure I'm calling the Rule.Name property correctly in the case statement, or if there's perhaps a better property to call for each case:
Public Sub saveAttch(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim fso As Object
Dim oldName
Dim saveFolder As String
Dim outlookRuleName As String
Dim folderLocation As String
outlookRuleName = Rule.Name
Select Case outlookRuleName
Case "TX Sales Log"
folderLocation = "Sales Projections\TX Goal Tracking Logs\"
Case "CA Sales Log"
folderLocation = "Sales Projections\CA Combined\CA Sales Logs\"
Case Else
folderLocation = "My Received Files\"
End Select
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "\Documents\" & folderLocation
Dim file As String
Dim DateFormat As String
Dim newName As String
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each objAtt In itm.Attachments
file = saveFolder & objAtt.DisplayName
objAtt.SaveAsFile file
Set oldName = fso.GetFile(file)
DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
newName = DateFormat & objAtt.DisplayName
oldName.Name = newName
Set objAtt = Nothing
Next
......
Amar says
Hi Diane
When I run this macro on my outlook, nothing happens at all. I have selected a few emails with attachments, and nothing whatsoever. I have enabled macros in trust centre too. I am running Office 2010. What do I do??
Diane Poremsky says
Add a signle quote ' in front of on error resume next and run it - hopefully it will error and give us a clue. Does Attachments folder exist under Documents? If you changed the folder, did you end the path with \ as in the original code? "\Documents\Attachments\"
Reda says
Hello, please help me, this is exactly the macro that I need, I just want my files renamed attachments with the email sender, what's the code added
Diane Poremsky says
This sets the name in the macro: newName = DateFormat & objAtt.DisplayName
use newName = itm.sendername
If the sender name has characters not valid for filenames, you'll need to strip them out using a function such as the stripillegalchar function at https://www.slipstick.com/developer/code-samples/save-messages-and-attachments-in-a-new-folder/
you'd use newName = StripIllegalChar(itm.sendername) with that function
Andy says
Hi Diane - I modified your code so the date would be added to the end of the filename. I split the filename from its extension, then reassemble the name with the date inserted in between. Unfortunately, it doesn't work if someone includes a period in their filename. My code reads that first one instead of the one just before the extension. I think I need to make it start from the end of the filename, and add some "if" statements to deal with three letter and four letter extensions properly. Does that sound correct to you or am I oversimplifying? Thanks!
Diane Poremsky says
Hmmm. Count = InStrRev(newName, ".") should get the period before the extension.
From the last macro on the page:
Get the position of the last dot:
Count = InStrRev(newName, ".")
get the filename, no extension:
FnName = Left(newName, Count - 1)
get the extension (and the dot):
fileext = Right(newName, Len(newName) - Count + 1)
Eric says
How do I add a msg box, when no mail with attachment is selected and a count msgbox with how many attachments have been saved to disk?
Diane Poremsky says
You mean after the macro runs, with the total counts?
Add total = 1 before the loop that saves attachments.
As each attachment is saved, add total = total + 1.
At the end use msgbox "Total attachments saved " & total
jeffvts says
Thanks, I tried running the section of code by itself and incorporated into the "Run a script" code as well, but seemed to not work completely.... How would you use it or insert it? here's how I used it...
Public Sub saveAttachtoDiskRule(itm As Outlook.MailItem)
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 & "\\SIMS1\"
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each objAtt In itm.Attachments
file = saveFolder & objAtt.DisplayName
objAtt.SaveAsFile file
Set oldName = fso.GetFile(file)
DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
newName = DateFormat & objAtt.DisplayName
oldName.Name = newName
Set objAtt = Nothing
Next
Set fso = Nothing
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.Item(i).FileName
' This code looks at the last 4 characters in a filename
sFileType = LCase$(Right$(strFile, 4))
Select Case sFileType
' Add additional file types below
Case ".jpg", ".png", ".gif"
If objAttachments.Item(i).Size < 5200 Then
GoTo nexti
End If
End Select
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
nexti:
Next i
End Sub
Sub SaveToDisk()
End Sub
Diane Poremsky says
You need to the select case code up where you are working with the attachments (and use the correct object names).
[top snipped]
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For i = itm.Attachments.count To 1 Step -1
strFile = itm.Attachments.item(i).FileName
' This code looks at the last 4 characters in a filename
sFileType = LCase$(Right$(strFile, 4))
Select Case sFileType
' Add additional file types below
Case ".jpg", ".png", ".gif"
If objAttachments.Item(i).Size < 5200 Then GoTo nexti End If End Select ' Combine with the path to the Temp folder. File = saveFolder & strFile ' objAtt.SaveAsFile filenexti: Next i Set oldName = fso.GetFile(file) DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ") newName = DateFormat & objAtt.DisplayName oldName.Name = newName Set objAtt = Nothing Next Set fso = Nothing End Sub
Jeff says
...and is there an "IF" statement I can add to the code that can help me filter in "Excel" files to the drive/folder
Diane Poremsky says
The code at the end of this article shows how to save based on file extension.
https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/
something like this:
Select Case sFileType
Case ".jpg", ".png", ".gif"
saveto = "\Pictures\"
Case "xlsx"
saveto = "\Excel\"
case "docx"
saveto = "\Documents\"
End Select
saveFolder = enviro & saveto
Jeff says
I successfully used the "run a script" version to a folde, but not a network drive..,, does VB need more lines of
Code to save to a network drive????
Diane Poremsky says
saveFolder = "\\servername\path\to\folder" should work for the path as long as you have permission to write to the folder.
What happens when you try? Any error messages? Anything in the event viewer?
Jeff Sims says
No, error messages, Nothing in Event logs...
April says
I'm stuck and need your expertise. I've use the script below to save the email attachment to a local drive but would like to replace the file name with the subject line.
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\attached"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub
Thank you in advance.
Diane Poremsky says
you'll replace objAtt.DisplayName with itm.subject but unless the subject is know to not have any illegal characters, you'll need to clear it.
See https://www.slipstick.com/developer/code-samples/save-selected-message-file/ for code to strip it.
April says
Thank you for your generosity and for sharing your knowledge Diane. I tried to copy the code you provided to strip the illegal characters to my existing one above. It appears it cannot be combined, do i have to do it in a separate module,if yes, how do I run the macros to perform 2 tasks at the same time? Sorry, very little knowledge with VB.
Also, is it possible to just run the code for specific sender only?
Diane Poremsky says
Get the ReplaceCharsForFileName function from that page - i like to put it in a new module with any other functions as it can be shared with other macros - then in the macro you are using, after you get the file name that needs illegal characters removed, add this line, where sName is the variable you used for the filename (you can change sName to whatever you need) - or you can use sName = itm.subject then use file = saveFolder & sName
ReplaceCharsForFileName sName, "-"
Ganesh says
Very good it works perfectly from outlook.
After saving the attachment with date and time stamp, I want send this saved file to new address with subject "New mail".
Please can you help me on that ?
Diane Poremsky says
Assuming you do it immediately, you just need to create a new message and use attachments.add (file) - you'll have the path to the file from saving it. (if you rename the file after saving, the path should be savefolder & newname instead of file)
Code sample here: https://www.slipstick.com/developer/create-a-new-message-using-vba/
Warren Cramton says
I've tried making the suggested change so that it renames the attachment to the email Subject line but I'm not having any luck getting it to work.
I am an absolute novice at this. Any chance you can edit the first Macro to the exact content I need? The PDF attachment needs to be saved to C:\Temp and renamed to the Subject line of the message.
This is for Outlook 2013. Thanks in advance.
April says
Hi Warren,
I know it's almost been a year and I'm on the same boat right now. Were you able to get the issue resolved? Hope you can share it with me.
Thanks.
Perry Garrod says
Hi
I'd like to have my saved attachements, which I split out from the email, to have the same date - or within seconds - of the saved mail.
The attachments I am saving are scanned and them emailed, so it would be nice to be able to see then next to each other in the directory, but the scanned attachments have the scan date & time.
Is it posssible to save an attachment with either modified or create dates being the date the attachment is actually saved, i.e. same time as the email itself?
Doing this in VBSO VB
Thanks
Perry
Diane Poremsky says
You can change the attachment name - if you want to use the time you saved it, the value would be Now (or Now()).
Venu says
Macro works fine, but I wanted to save the attachment with subject and sendername also along with date stamp. Subject line can be limited upto first 15 characters if its too long.
Diane Poremsky says
Not a problem, you need to use something like
newName = left(itm.subject,15) & itm.sndername & dateformat