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
Any way to use a Save As Dialog instead, let users choose where to save? Similar to BrowseForFolder but more advanced?
Diane, It seems that when I really get stumped, and after hours of searching, I eventually find the solution in one your articles. Thank you. What I am trying to do is add the senders name to the outputted file name. It would read Date; Time (if I can figure out how to use colons between the hours and minutes); Subject; From. Is this possible? Also, is it possible to add a bold horizontal line, as in when printing e-mails? Thank you.
Does anyone have an idea why the first set of code would only process 70-72 files before it stops?
Any error messages when it stops?
No error message. It just processes 70 messages and doesn't work. I find 3-4 MS Word docs open on the screen.
Diane good morning!
I really liked the macros! Especially to save MSG to DOCX.
But with Word 2019 there is a little problem, which I think I solved.
These two lines do not work
'' 'Dim objWord As Word.Application
'' 'Dim objDoc As Word.Document
I moved to:
Dim objWord As Object
Dim objDoc As Object
Set objWord = CreateObject ("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.Visible = True
And "FileFormat: = wdFormatXMLDocument" doesn't work either.
I changed it to "FileFormat: = 12" and it worked !!!
I was looking for this macro for some time !! And all the ones I found on the internet didn't work ...
I just want to include the option to choose the directory when saving. But that, I think, is easy.
Hello,
Thanks for the Macros. The save as doc macro works great when I run it but I would like to be able to modify it to be added as a rule. What modifications are needed for that. Thanks
The itemadd macro would be easiest to change -
Change this
Private Sub objItems_ItemAdd(ByVal aItem As Object)
to
Public Sub SaveFiles(ByVal aItem As Object)
You use any name where I have SaveFiles.
On the others, you change the macro name as above, but also need to remove any lines that set items - like
For Each Item In Selection
For Each Item In mail.Items
as this (ByVal aItem As Object) sets the object passed by the rule.
in those examples, the macros use item as the object name - which is in the macro title: (ByVal aItem As Object) - make sure the object name matches what is in the macro
Thanks for the reply. I did not see the ItemAdd Macro before. This will actually work better for me than having a rule! I have tried to set it up but I am getting an error. I copied and pasted the macros along with the Sub from the one above it and changed the name of the folder to the folder I have under my inbox. When I drag an email to the folder I get an error. I have attached a screenshot. Thank you for your help on this.
Hello again
I changed (ByVal aItem As Object) to (ByVal Item As Object) and it is working now. I hope this is the correct way. Thank you again for your help.
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