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