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 athttp://slipstick.me/u1a2d strFolderpath = BrowseForFolder(enviro & "\documents\") 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(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) 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:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
To put the macro code in ThisOutlookSession:
- Expand Project1 and double click on ThisOutlookSession.
- 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
More Information
- How to Save Email in Windows File System
- Import Messages from File System into Outlook Folders
- OWA: Save Messages to My Documents
- Save a Message as HTML and Delete the (Annoying) Folder
- Save email message as text file
- Save Outlook Email as a PDF
- Saving All Messages to the Hard Drive Using VBA
To save all incoming messages as files as they arrive in your Inbox, see E-Mail: Save new items immediately as files (VBOffice.net)
how to add timestamp after .msg extension?
I'm not sure I'd do that but its just a matter of changing the order in sname variable:
sName = sName & ".msg" & Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem)
Hi Daine,
wishing you a good day.
I am using your code SaveMessageAsMsg() but when i search a email in All mailboxes and after finding email , this function does not work.
please let us know how to change a part of code to use it.
it's not working on the search results? The first 2 should work on search results - I'll double check.
Hello Diane,
Thank you for the fabulous code--it's a real time saver!
Would you know how to run this macro and have automatic replies included? They are not saved when the macro is run.
I am new to this but have tried looking in the comments and searching Google, and have not found my answer. I'd really appreciate it if you could help me out.
Thank you,
Michelle
Hi Daine,
Thanks for the sharing.
However, when I run the code, it appears Run-time error. I tried to debug the highlighted row is on oMail.SaveAs sPath & sName, olMSG
What i am trying to do is I would like to save a specific email with the same SUBJECT+current date to a specific folder with named 'today date.
Do I need to change any parameter from your code? Also the place i would like to save is a company network drive, sth like M:\HK\Dailytest\
Thanks.
It may be the fact that you are trying to save to a network drive - Outlook (and macros) can be funny about network drives. On the other hand, in looking at the screenshot, it looks like you are using the original code, which saves to the user's Documents folder.
Open the immediate window - (Ctrl+G or look on the View menu) - the Debug.print line writes the file path there so you can see if its correct.
Diane, I have been using your program and it is great (here it comes)...but, I noticed if a start out with 3,180 emails when I finish running your program that I only get 2,924 .msg files? Figuring that it's encountering messages with the same received date and subject that its simply overwriting the files. So I tried changing the sname item to EntryID which is the closest thing I can find to a unique identifier for email and the numbers are the same? Do you have any suggestions?
Thanks
I would use the current (saved) date and time (its a shorter value than the entryid) or number the saves (i have a macro here somewhere that does this).
You could use the current time (as hhnnss) as a unique number:
Diane, I want to thank you and apologize. When I ask my question above, I broke the cardinal rule. That rule was to read all of the prior comments before posting a new question. In one your prior response to a comment you mentioned an icount feature. This icount feature coupled with the subject provided me with enough uniqueness. So no overwrites! In my application of your code current time was not unique enough. I can't tell you how much time this code will save me! Again thanks, happy holiday and a prosperous new year!
You are forgiven... 221 comments is a bit much to make you read all of them. :)
Glad you got it solved.
The code above works great on normal email messages. the code uses "IPM.Note"...
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
What do I need to change in the code to allow it to save messages that have a MessageClass of REPORT.IPM.note.DR or REPORT.IPM.Note.Relayed
Since they all contain ipm.note, check for that in the message class name:
If instr(objItem.MessageClass, "IPM.Note") > 0 Then
I suggest to add a line to account for long email titles resulting in too long filename:
If Len(sName) > 250 Then sName = Left(sName, 250) & ".msg"
`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 sPath As String Dim dtDate As Date Dim sName As String Dim enviro As String UserForm1.Show ‘ Works until here, opens UserForm 1 allows section and allows pressing of OKButton_Click() but then ‘gets errors shown below – see next to last sub, (1) objSentItems2_ItemAdd at end. 'The sub below, Public Sub objSentItems2_ItemAdd(ByVal Item As Object), 'is what the the Oneonta Button on UserForm1 will call to put in Oneonta Folder 'I put the whole thing in the user form. That didnt work so I took out the body and just left the call in ‘did not work either End Sub Public Sub objSentItems2_ItemAdd(ByVal Item As Object) Dim sPath As String Dim dtDate As Date Dim sName As String Dim enviro As String sName = Item.Subject ReplaceCharsForFileName sName, "-" dtDate = Item.ReceivedTime sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _ vbUseSystem) & Format(dtDate, "-hhnnss", _ vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg" 'sPath below works perfectly in your orignal macro sPath = "\\HVSBS\PROJECTS\Oneonta\"… Read more »
Ok... (I added the macro to the page as well). This goes into a module - it can't be declared in Thisoutlooksession. Public lstNum As Long This goes into Thisoutlooksession '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 UserForm1.Show 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(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),… Read more »