An Outlook user wanted to save all of his messages to his hard drive in *.doc format, so that the messages would be in a universal format and the attachments would stay with the document. While you can do this in Outlook, it takes several steps: you need to open the message, go into Edit mode, change the message format to Rich Text (RTF) and save it. Then use SaveAs to save the message to the hard drive.
Using VBA speeds the process up quite a bit.
To save attachments to your hard drive then open them: Save and Open an Attachment using VBA. To save attachments and remove them from the message, see Save and Delete Attachments from Outlook messages
The code adds the message date and time stamp to the filename, to avoid problems if multiple messages have the same subject. You could also add the sender's name to the filename, if desired. The date and time stamp code was taken from E-Mail: Save new items immediately as files.
Save selected messages as docx file type
This new version of the SaveSelectedAsDoc macro saves the selected messages as the docx file type. The other macros on the page use Outlook's supported file type of .doc.
Because Outlook doesn't have built in support to save a message as a docx file, you must set the reference to the Word Object Model in the VB Editor's Tools, References dialog and use Word to save the message.
Sub SaveSelectedAsDocX() Dim currentExplorer As Explorer Dim Selection As Selection Dim Item As Object Dim dtDate As Date Dim sName As String Dim objInsp As Outlook.Inspector Dim objWord As Word.Application Dim objDoc As Word.Document Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection For Each Item In Selection Set objInsp = Item.GetInspector Set objDoc = objInsp.WordEditor Set objWord = objDoc.Application sName = Item.Subject ReplaceCharsForFileName sName, "_" dtDate = Item.ReceivedTime sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _ vbUseSystem) & Format(dtDate, "hhnnss", _ vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName objDoc.SaveAs2 Filename:="D:\Email\" & sName & ".docx", FileFormat:= _ wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _ :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _ :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _ SaveAsAOCELetter:=False, CompatibilityMode:=15 Next Item 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, Chr(34), sChr) 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, " ", sChr) sName = Replace(sName, "{", sChr) sName = Replace(sName, "[", sChr) sName = Replace(sName, "]", sChr) sName = Replace(sName, "}", sChr) End Sub
Save as Doc Macro
If the folder you want to save the documents to does not exist, create it before running the macro.
To use this code, open the VBA editor using Alt+F11 and paste this code into ThisOutlookSession. Change the path where the documents will be saved. Select a folder and run the macro. All messages within the folder will be saved as a Word document file.
A version of the macro that saves to a folder matching the folder name of the message (but not the full path, sorry) and stored under Documents, is available here.
Sub SaveAsDoc() Dim myolApp As Outlook.Application Dim Item As Object Dim dtDate As Date Dim sName As String Set myolApp = CreateObject("Outlook.Application") Set mail = myolApp.ActiveExplorer.CurrentFolder For Each Item In mail.Items Item.BodyFormat = olFormatRichText 'If you want to convert all messages to RTF, uncomment this line. 'Otherwise, the message format is not changed. ' Item.Save sName = Item.Subject ReplaceCharsForFileName sName, "_" dtDate = Item.ReceivedTime sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _ vbUseSystem) & Format(dtDate, "hhnnss", _ vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName Item.SaveAs "C:\email\" & sName & ".doc", olDoc Next Item 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, Chr(34), sChr) 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, " ", sChr) sName = Replace(sName, "{", sChr) sName = Replace(sName, "[", sChr) sName = Replace(sName, "]", sChr) sName = Replace(sName, "}", sChr) End Sub
Save Selected Messages
This version of the macro saves just the selected messages, not every message in the folder.
Sub SaveSelectedAsDoc() Dim currentExplorer As Explorer Dim Selection As Selection Dim Item As Object Dim dtDate As Date Dim sName As String Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection For Each Item In Selection Item.BodyFormat = olFormatRichText 'If you want to convert all messages to RTF, uncomment this line. 'Otherwise, the message format is not changed. ' Item.Save sName = Item.Subject ReplaceCharsForFileName sName, "_" dtDate = Item.ReceivedTime sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _ vbUseSystem) & Format(dtDate, "hhnnss", _ vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName Item.SaveAs "C:\email\" & sName & ".doc", olDoc Next Item Set currentExplorer = Nothing Set Selection = 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, Chr(34), sChr) 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, " ", sChr) sName = Replace(sName, "{", sChr) sName = Replace(sName, "[", sChr) sName = Replace(sName, "]", sChr) sName = Replace(sName, "}", sChr) End Sub
Use an ItemAdd Macro to Save as .Doc
This version of the macro is saves messages as doc files as they are dropped in a folder, either by rules or by dragging the message to the folder. As written, it watches a folder under the Inbox.
Add the ReplaceCharsForFileName sub (from the macro above) at the end of this macro.
Option Explicit Private objNS As Outlook.NameSpace Private WithEvents objItems As Outlook.Items Private Sub Application_Startup() Dim objFolder As Outlook.folder Set objNS = Application.GetNamespace("MAPI") Set objFolder = objNS.GetDefaultFolder(olFolderInbox) Set objItems = objFolder.Folders("Folder01").Items Set objFolder = Nothing End Sub Private Sub objItems_ItemAdd(ByVal aItem As Object) Dim dtDate As Date Dim sName As String Item.BodyFormat = olFormatRichText 'If you want to convert all messages to RTF, uncomment this line. 'Otherwise, the message format is not changed. ' Item.Save sName = Item.Subject ReplaceCharsForFileName sName, "_" dtDate = Item.ReceivedTime sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _ vbUseSystem) & Format(dtDate, "hhnnss", _ vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName Item.SaveAs "C:\email\" & sName & ".doc", olDoc End Sub ' put the ReplaceCharsForFileName sub here
Hello Diane, first of all this is a game changer for me so thank you so much.
Is there a way for the "Save Selected Messages" macro so it saves everything in the email including pictures? (currently pictures inserted do not show up) Does it need to converted to docx instead for it tor work? If so can you tell me what I need to edit?
Thank you so much!!!
Do you want to save the embedded pictures as individual images or embedded in the file?
Hello Diane,
I'm using the 'Save Selected Messages' version of your script and it worked great for me, but for one item. The message in Outlook 2016 gets converted to RTF for the save and stays that way in Outlook, but I never uncommented the "save" line:
'If you want to convert all messages to RTF, uncomment this line.
'Otherwise, the message format is not changed.
' Item.Save
Any suggestions as to why it is changing the email to RTF and not reverting it back to HTML? I have tried restarting Outlook to see if it was just temporary, but the message that I saved to file is still in RTF om Outlook.
Hi Diane, can this macro be altered to save messages as .docx?
I'm using the macro, which is great, but I'm finding I continually need to convert docs to docx, any suggestions?
Yes, it can save as docx - you need to use the pdf macro and change the file type - https://www.slipstick.com/developer/code-samples/save-outlook-email-pdf/
wrdApp.ActiveDocument.SaveAs2 FileName:= _
strToSaveAs, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
for 'Save as Doc Macro' the line
dtDate = aItem.ReceivedTime
aitem doesn't exist, need to remove the 'a' for it to work. might have been a typo
It used to exist and i "cleaned" it up to use just Item. Thanks for catching what I missed.
Yes. I would like to see the pictures and not just the link. Can I turn first with a macro in HTML and then in word? Thanks
Hmmm. Possibly. I wonder if Word can convert a picture to embedded... will check on that too. I guess I need to finish my article that saves HTML pages.
Is possible including photo and not adress of the photo, from email derived form internet...excuse me i'm italian
thanks
I'm not really sure what you want to do. Do you want to embed images that were linked? I know you can if you save as HTML but I'm not sure you can when you save as a doc.
Thanks Diane for this slick code. Is there a easy way to also perform this on just "Selected" emails instead of the whole(current) folder . Also if I wanted to add the "from" name to the "doc" name would it be sName=aItem.Subject + From (or is it a comma or seperate line?). Thanks for your help!
Dale
Yeah - you need to change from this: For Each aItem In mail.Items to For Each aItem In Selection and dim/set the objects. (I'll add a second macro to the page that does that.)
Dim currentExplorer As Explorer
Dim Selection As Selection
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each aItem In Selection
Hi Diane, you have posted several create codes; however my limited knowledge of VBA is contributing to my errors. I am trying to create a code that will save emails as Word Documents on my hard drive. I am moving the appropriate items to a folder in my inbox named: @SaveAsDoc and I have a folder on my hard drive saved at this path: C:Documents and Settingsjennifer.mcdonald2SaveAsDocOutlookMessages .
I have tried cutting and pasting the code and renaming the folders, but I think my process is a little more involved since I am already moving the items to a subfolder of the inbox. I found some information that left me to believe I may need to use this: Items.ItemAdd Event . I continue to get an error highlighting "Dim" that states Complie Error: Expected End of Statement. Can you possibly help me?
Thanks,
Jennifer
So you want to save the message as a doc file and move it? Or save it only after it is moved?
I added an itemadd macro to the article - the folder path assumes a subfolder of the inbox.