This code sample will save one or more selected messages to your My Documents folder as individual .msg files. The file name includes the received date and time. Spaces and invalid characters are replaced with underscores.

A variation of this macro that saves as a text file is at Save email message as text file. Included is a version that saves selected messages as one text file. For more information on saving to other formats, see How to Save Email in Windows File System.

See How to use the VBA Editor if you don't know how to use macros or the VBA Editor.

Updated December 17 2014: macro checks for message class and skips meetings and report/receipt messages. I also added character replacements for single quote and asterisk.

Option Explicit
Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
 
    enviro = CStr(Environ("USERPROFILE"))
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
   
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
     
    sPath = enviro & "\Documents\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG
  
  End If
  Next
  
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, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

Pick the Folder Location

To select the folder where you want to save the selected messages, you can use the BrowseForFolder function. You'll need to select the folder before you begin saving the messages. If you select it after the For Each loop, you'll need to select a folder for each message.

Don't forget to get the BrowseForFolder function.

Option Explicit
Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
  Dim strFolderpath As String
  
    enviro = CStr(Environ("USERPROFILE"))
'Defaults to Documents folder
' get the function at http://slipstick.me/u1a2d
strFolderpath = BrowseForFolder(enviro & "\documents\")

' Cleanly exit if Cancel is clicked
 If StrFolderpath = "False" Then
      Cancel = True
      Exit Sub
  End If
   
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
    
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
  
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
      
  sPath = strFolderpath & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG
   
  End If
  Next
   
End Sub

Save messages as they are sent

This version of the macro will save messages to the user's My Documents folder as they are added to the Sent Items folder, using "Now" to create the time and date stamp. If the subject contains illegal filename characters, you'll need the ReplaceCharsForFileName sub above.

Private WithEvents objSentItems As Items

Private Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub
 
Private Sub objSentItems_ItemAdd(ByVal Item As Object)
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
 
enviro = CStr(Environ("USERPROFILE"))
   
  sName = Item.Subject
  ReplaceCharsForFileName sName, "-"
 
  dtDate = Item.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
     
    sPath = enviro & "\Documents\"
  Debug.Print sPath & sName
  Item.SaveAs sPath & sName, olMSG
End Sub

Use a Userform to display locations to choose from

This version of the macro uses a userform to display locations to choose from.

To use this macro, you need to put this line in a module, not in Thisoutlooksession.

Public lstNum As Long

This code goes into ThiOutlookSession:

Option Explicit
Public WithEvents objSentItems As Items

Public Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Dim objNS As Object
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub
Public Sub objSentItems_ItemAdd(ByVal Item As Object)
Dim dtDate As Date
Dim sName As String
Dim sPath As String
UserForm1.Show

Debug.Print lstNum
    Select Case lstNum
    Case -1
'  -1 is what you want to use if nothing is selected
         sPath = "C:\Users\slipstick\Documents\"
    Case 0
         sPath = "C:\Users\slipstick\Documents\Email Attach\"
    Case 1
        sPath = "C:\Users\slipstick\Documents\pics\"
    Case 2
         sPath = "C:\Users\slipstick\Documents\Balsam Lake\"
    End Select

sName = Item.Subject
ReplaceCharsForFileName sName, "-"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
 
Debug.Print sPath & sName
Item.SaveAs sPath & sName, olMSG
End Sub

Public Sub ReplaceCharsForFileName(sSubject As String, _
sChr As String _
)
  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, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

This code goes into the UserForm. Name the OK button btnOK. See VBA UserForm sample: Select from a list of templates for step-by-step instructions to design the userform.

Private Sub UserForm_Initialize()
  With ListBox1
    .AddItem "Email Attach"
    .AddItem "pics"
    .AddItem "Balsam Lake"
  End With
End Sub

Private Sub btnOK_Click()
    lstNum = ListBox1.ListIndex
    Unload Me
End Sub

When you send a message, the userform comes up with the list of folder locations to choose from.

How to use the macros on this page

First: You need to have macro security set to low during testing. The macros will not work otherwise.

To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, look at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

Some macros need to be in ThisOutlookSession, others go into a module or can be placed in either ThisOutlookSession or a module. The instructions are below.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To put the code in a module:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

To put the macro code in ThisOutlookSession:

1. Expand Project1 and double click on ThisOutlookSession.
2. Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)

More information as well as screenshots are at How to use the VBA Editor