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
Dan says
Any way to use a Save As Dialog instead, let users choose where to save? Similar to BrowseForFolder but more advanced?
James Meadows says
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.
Brian says
Does anyone have an idea why the first set of code would only process 70-72 files before it stops?
Diane Poremsky says
Any error messages when it stops?
Brian says
No error message. It just processes 70 messages and doesn't work. I find 3-4 MS Word docs open on the screen.
Aleixa says
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.
jf83 says
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
Diane Poremsky says
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
jf83 says
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.
jf83 says
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.
Esteban Ramos says
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!!!
Diane Poremsky says
Do you want to save the embedded pictures as individual images or embedded in the file?
Craig says
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.
Dave says
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?
Diane Poremsky says
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
amen says
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
Diane Poremsky says
It used to exist and i "cleaned" it up to use just Item. Thanks for catching what I missed.
Vincenzo says
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
Diane Poremsky says
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.
vincenzo says
Is possible including photo and not adress of the photo, from email derived form internet...excuse me i'm italian
thanks
Diane Poremsky says
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.
Dale says
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
Diane Poremsky says
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
Jennifer McDonald says
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
Diane Poremsky says
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.
Pete Constantine says
Diane,
Thanks for the awesome code!! It works exactly as described and flawlessly. In looking at the code, I am trying to determine if I can apply this to a specific folder; not just the current folder. I imagine it is associated with this particular line :
"Set mail = myolApp.ActiveExplorer.CurrentFolder"
However, my very limited knowledge of VBA inhibits my ability to figure it out. Do you have any pointers?
Thanks again for this.
Diane Poremsky says
that is the link you need to change. Set mail = myolapp.GetDefaultFolder(olFolderinbox) would apply it to the Inbox.
See https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/ for more information.
Dwight Huse says
Diane,
I had a terrible time getting this to work for me. I kept getting a VBA message box stating, Compile Error: Sub or Function not defined. I struggled for a long time until I realized that I must have captured some stray hidden characters when I copied your code. Once I cleaned up all those hidden characters, your code works great. I was dismayed that a dozen coding sites trying to answer this same VBA error message for others have not been able to identify a simple problem like this.
Thank you so very much for sharing your code.
-Dwight
Diane Poremsky says
Thanks for the update.
A says
This is great, but is there a way to delete all attachments from the message before they are saved, therefore creating just the email text as a Word doc? Obviously this can be commented out like the convert to RTF line.
Diane Poremsky says
Yes, you can do that.
Add this before converting the message to rtf format
Dim myAttachment As Attachment
Dim myAttachments As Attachments
Dim lngAttachmentCount As Long
For Each aItem In selItems
Set myAttachments = aItem.Attachments
lngAttachmentCount = myAttachments.Count
' Loop through attachments until attachment count = 0.
While lngAttachmentCount > 0
myAttachments(1).Delete
lngAttachmentCount = myAttachments.Count
Wend
aItem.Save
Next
To samples that work with attachments:
https://www.slipstick.com/developer/save-attachments-to-the-hard-drive/
https://www.slipstick.com/developer/remove-attachments-from-sent-messages/
Sus Boyce says
Bless your heart - thank you very much. this is precisely what I was look for. Thank you for saving me tons of time.