Save Messages as *.DOC File Type

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 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", olRTF

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:\mail\" & sName & ".doc", olRTF
 
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", olRTF
 
End Sub

' put the ReplaceCharsForFileName sub here