Joel asked
I get a lot of pictures from a photographer, he writes the details in the email body. Is there a way to save each email in a separate folder, the name should be the subject line? and the email body should be saved as a text file?
Sure, you can do this using VBA.
This macro creates a folder in your Documents folder using the subject name (after removing any illegal characters) and then saves the message (as HTML) and any attachments to the folder.
If you want the message saves as a text or doc file, change
objMsg.SaveAs strFolderpath & strName & ".htm", olHTML to
objMsg.SaveAs strFolderpath & strName & ".txt", olTXT or
objMsg.SaveAs strFolderpath & strName & ".rtf", olRTF
To save it as a message file, use
objMsg.SaveAs strFolderpath & strName & ".msg", olMsg
To use, select the message then run the macro.
Public Sub SaveMessagesAndAttachments() 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 strName As String Dim strFolderpath As String Dim strDeletedFiles As String Dim sFileType As String Dim enviro As String enviro = CStr(Environ("USERPROFILE")) Dim fso As Object Dim oldName Set fso = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set objOL = CreateObject("Outlook.Application") Set objMsg = objOL.ActiveExplorer.Selection.Item(1) strName = StripIllegalChar(objMsg.Subject) strFolderpath = enviro & "\Documents\" & strName & "\" If Not fso.FolderExists(strFolderpath) Then fso.CreateFolder (strFolderpath) End If objMsg.SaveAs strFolderpath & strName & ".htm", olHTML Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then For i = lngCount To 1 Step -1 strFile = objAttachments.Item(i).FileName Debug.Print strFile strFile = strFolderpath & strFile objAttachments.Item(i).SaveAsFile strFile Next i End If ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub Function StripIllegalChar(StrInput) Dim RegX As Object Set RegX = CreateObject("vbscript.regexp") RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" RegX.IgnoreCase = True RegX.Global = True StripIllegalChar = RegX.Replace(StrInput, "") ExitFunction: Set RegX = Nothing End Function
Save Attachment to a Specific Folder
This version of the macro saves the attached images to a specific folder using a filename format that includes the date. I use this to save images from incoming email. If you want to save the files but don't want to rename them, remove the lines that change the oldName to the newname.
Select the message then run the macro.
Public Sub SaveAttachments() 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 Dim sFileType As String Dim enviro As String enviro = CStr(Environ("USERPROFILE")) Dim fso As Object Dim oldName Set fso = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set objOL = CreateObject("Outlook.Application") Set objMsg = objOL.ActiveExplorer.Selection.Item(1) strFolderpath = enviro & "\Attachments\" '& Format(objMsg.SentOn, "yymd") 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 'Get the file name Set oldName = fso.GetFile(strFile) Debug.Print oldName sFileType = LCase$(Right$(oldName, 6)) Debug.Print sFileType DateFormat = Format(objMsg.SentOn, "yymmdd-") newName = "RC" & DateFormat & sFileType Debug.Print newName oldName.Name = newName Next i End If ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub
Save a Message and Attachments to a New Folder
This is the macro I use to save a message and it's attachments to a new folder named for the message subject. I shorten the subject to 40 characters to avoid problems with long file names.
To use, select one message and run the macro. If more than one message is selected, it runs only on the first message.
Public Sub SaveMessagesAndAttachments() 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 StrName As String Dim strTime 'As String Dim StrFolderPath As String Dim FSO As Object Dim oldName Set FSO = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set objOL = Outlook.Application Set objMsg = objOL.ActiveExplorer.Selection.Item(1) ' remove illegal characters and shorten name StrName = StripIllegalChar(objMsg.Subject) StrName = Left(StrName, 40) strTime = DateValue(objMsg.ReceivedTime) '& TimeValue(objMsg.ReceivedTime) ' I use this to reduce changes of duplicate names strTime = Format(objMsg.ReceivedTime, "-hhmmss") Debug.Print strTime strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) Debug.Print strFolderpath On Error Resume Next StrFolderPath = StrFolderPath & "\Attachments\" & StrName & strTime & "\" ' create folder if doesn't exist If Not FSO.FolderExists(StrFolderPath) Then FSO.CreateFolder (StrFolderPath) End If ' Save message and as html and doc file type objMsg.SaveAs StrFolderPath & StrName & ".msg", olMsg objMsg.SaveAs StrFolderPath & StrName & ".doc", olRTF objMsg.SaveAs StrFolderPath & StrName & ".htm", olHTML 'save any attachments also Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then For i = lngCount To 1 Step -1 StrFile = objAttachments.Item(i).FileName Debug.Print StrFile StrFile = StrFolderPath & StrFile objAttachments.Item(i).SaveAsFile StrFile Next i End If ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub
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
Im trying to save as a pdf instead of an html. Changing hmtl to PDF doesn't work.
objMsg.SaveAs strFolderpath & strName & " - " & SName & ".htm", olHTML
That won't work if the message is not pdf. This shows hwo to do it https://www.slipstick.com/developer/code-samples/save-outlook-email-pdf/ - it saves selected messages as pdf, so you could call it from the macro on this page - although it won't save in the same folder as the others without tweaking.
I've tried everything I can, but I can't get this to work with a do loop.
How can I use the first code above, but so It will work with all emails that I have selected?
Replace:
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)
With these lines:
Dim objItems As Outlook.Items
Dim objFolder As Outlook.MAPIFolder
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each objMsg In objItems
After the end if, add this:
Next
I'm still having issues. When I add your modifications, I'm able to make it output the folder names, but nothing goes into the folders. Here is my original code that works when I select (1) email. If I replace what you're saying it doesn't work. Public Sub SaveEmailsAndAttachments() 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 dtDate As Date Dim SName As String Dim strName As String Dim strFolderpath As String Dim strDeletedFiles As String Dim sFileType As String Dim fso As Object Dim oldName Set fso = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set objOL = CreateObject("Outlook.Application") Set objMsg = objOL.ActiveExplorer.Selection.Item(1) strName = StripIllegalChar(objMsg.Subject) strFolderpath = "E:\Downloads\" & strName & "\" If Not fso.FolderExists(strFolderpath) Then fso.CreateFolder (strFolderpath) End If Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then dtDate = objMsg.SentOn SName = Format(dtDate, "yyyy-mm-dd", vbUseSystemDayOfWeek, vbUseSystem) For i = lngCount To 1 Step -1 If objAttachments.Item(i).Size > 5200 Then strFile = objAttachments.Item(i).FileName Debug.Print strFile strFile = strFolderpath & SName & " - " & strFile objAttachments.Item(i).SaveAsFile strFile objMsg.SaveAs strFolderpath & strName & " - " & SName &… Read more Âğ
Except for wordpress screwing up the ampersands and greater thans, the code looks ok and more importantly, it works when i tested it here.
Diane, I took your savemessagesand attachments and tried to incorporate your browse function. But am having a few issues. Can you look at my script and advise. ? Thanks, KURT issues: 1) Folder not being created. (with quoteID number from subject lline) 2) E-mail msg is being saved, attachements are saved. to path below. I would like them saved to a folder that I have created and named from number in the subject line. 3) attachments are being named which ever folder I pick from browse.( I just want attachments to be saved what ever they are named in e-maiil) Public Sub SaveMessagesAndAttachments() 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 StrName As String Dim StrFolderPath As String Dim strPath As String Dim sFileType As String Dim FSO As Object Dim oldName Set FSO = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set objOL = CreateObject("Outlook.Application") Set objMsg = objOL.ActiveExplorer.Selection.Item(1) StrName = Left(StrName, 6) ' quoteID number is 6 characters. StrFolderPath = BrowseForFolder("P:Clients17") ' create folder if doesn't exist If Not FSO.FolderExists(StrFolderPath) Then FSO.CreateFolder (StrFolderPath) End If ' Save message as msg file type… Read more Âğ
Sorry I missed this earlier. The problem with the code is a missing slash at the end of the folder path so it thinks the selected folder is part of the file name. Add the slash to the strfolderpath right after you select the folder. (If wordpress/php removes the slash, it belongs inside the quotes at the end.)
(looks like wordpress left the slash but screwed up the 'and' sign. :( )
The macro I tested (and works here) is attached.
Sheesh - I missed #1 - use this for the strfolderpath:
Hello, I am trying the save message and attachments, when I run. I get compile error: sub or function not defined. on thisline.
StrName = StripIllegalChar(objMsg.Subject)
Am I doing something wrong ?
Do you have the StripIllegalChar function? It's at the need of the first macro on the page.
OK. I added the StripIllegalChar function, it works now.
I would like to modify this. Instead of saving folder to a specific destination, I would like to have window open to choose location to save folder.
Can you help with that ?
Kurt
You need to use the browseforfolder function - https://www.slipstick.com/developer/code-samples/windows-filepaths-macro/
Hi,
I am new to this forum and novice to VBA.
When I run the third code above, there is an error
"Outlook can not save or create this file. Make sure that the disk you want to save the file on is not full, write protected or damaged"
It work with the 2 other codes, so I don't think it is error about the right to save files.
What could be the reasons and how to fix.
Thks
Hi,
what code will be, if i wanted to save selected messages and attachments separately (one mail per folder). Name of folder should be subject + date + time or sender mail adress + date + time. In folder should be saved mail in txt/html format and all attachments from that mail.
This part of the code sets it to be saved in a folder that uses the message subject:
strName = StripIllegalChar(objMsg.Subject)
strFolderpath = enviro & "\Documents\" & strName & "\"
you'd add a line to add the date and time to the subfolder name:
strName = strName & Format(objMsg.ReceivedTime, "yyyymmdd-hhmmss")
for address, you'd add objmsg.senderemailaddress to it ( or & " " & objmsg.senderemailaddress)
Hi , Diane How can I save a file include into a email by hyperlink?
you want to save an attachment and insert a link to the attachment in the original message? I have a macro here - https://www.outlook-tips.net/code-samples/save-and-delete-attachments/
Hi Diane , thank you for your replay and useful code but i'll try to explain better (better than before) what i would like to do. I receive many e-mail with link . In this link is present the attachment , then if i click on it attachment start a window that ask if I want open or save(download) the real doc (it is often a pdf). I would like to create (if is possible) a macro that save automatically this kind of pseudo attachment file too. The other file's attached (txt,word,excel and so on) are saved by code that you posted here . Best Regards
Ah. I have macros that will open the links but you'd need to use clickyes or a windows macro to respond to the open or save dialog (unless you choose never ask again). https://www.slipstick.com/developer/code-samples/open-hyperlinks-email-message/ will open the links (as long as the links are from the same domain, you could change the pattern so it only opens these links.)
Thank you Diane you are an angel :-)
Hi
I have macro that macro send emails with attachment but 500 emails to send so i can not add those in sent item folder
from setting i remove this add after sending email to sent item folder
problem is some emails send without attachments so i want identify which emails sent with & without attachments so please tell me any macro that copy paste emails from sent item folder paste in particular folder & then delete that permanently
Please help me