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(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:
- 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)
Hi All,
I used this script with success but faced issues with path/filename length.
It would be nice that at least the name of the msg file would be shortened till the maximum length.
I'm not sure how to implement it so any help is appreciated.
This block sets the file name -
sName = Item.Subject
ReplaceCharsForFileName sName, "-"
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
the first two lines use the subject and remove characters that are illegal in the file name. If you have a long subject, you can shorten it - this gets the first 20 characters of the subject.
sName = left(item.subject, 20)
This would remove illegal characters instead of replacing them
ReplaceCharsForFileName sName, ""
The next part is the received date - in 20211028-080822 format. The reason for using the full time is in the event there are two messages with the same subject and received minute.
You can shorten it to 2110280808 by removing 2 2's, the -, and the s's from the date format.
dtDate = Item.ReceivedTime
sName = Format(dtDate, "yymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "hhnn", _
vbUseSystemDayOfWeek, vbUseSystem)
This line puts the two together - you can remove '& -' to use "2110280808subject-20-character"
& "-" & sName & ".msg"
Hello Diane,
Thanks for your script, it has been a of a great help for me for almost 2 years now. Which is fantastic.
However, last week I updated from MS 2010 to O365 and since then the first time Outlook lauches all the new e-mails that were received overnight (when outlook was closed) are not flagged as new items and not backed up. The scripts starts normally and save all the new messages after outlook is opened, but I miss the automatick backups on the ones received overnight.
I've been manually saving those few e-mails, but was wondering if you have had (or know about) any similar issue and knows how I can work around it.
Appreciate your time and Attention
What type off email account are you using? It shouldn't matter... and there should be no differences with the versions.
Your VBA was updated to skip meetings and report/receipt messages. How do you include all selected items.
Remove this line and the matching End if. Then it will run on all items.
If objItem.MessageClass = "IPM.Note" Then
Hi Diane,
If I remove the line and matching End if, I get an error on Set oMail = objItem (Types don't match) when I try to safe a receipt message.
is objItem and omail dim'd as an object or mailitem? They needs to be object to work on non-email items.
Hi Diane,
Thanks for your response.
I tried to reply but it can't see my reaction so new attempt.
The code now is:
Dim oMail As Outlook.MailItem
Dim objItem As Object
When I change Outlook.MailItem into Object I get "Error 438 during execution. This feature or method is not supported by this object."
The code sample is working for me, for both email and meeting invites. (That's all I have in my test mailbox).
20210322-005132-subject.msg
20211020-115819-Declined- .msg <== meeting response
20210612-131347-Testing moving.msg <== meeting invite
I'm working with Office 365 in Belgium.
It's not a meeting but a report/receipt message.
Can that be the problem?
Complete code:
Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Object
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
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
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
Were you able to get your Received/Read Receipts to save?
I've also been trying to get this to work for some time. I've tried using *REPORT.IPM.NOTE.IPNRN and REPORT.IPM.NOTE.DR instead of IPM.Note, but neither one worked.
Nothing works unless it's IPM.Note (which Note can not be NOTE to work.)
Any further help would be great.
Hello, I was in need of a macro so as to send or reply to a message, create a .msg file, I'm not getting it, could you help me?
Hello,
I have been trying to use this script to save the emails from a public folder within Outlook but keep getting the error "Path Not Found". The script works fine with a small test folder under my inbox, so instantly I know the script can't see the Public Folder. I tried to modify the script using the info found here (olPublicFoldersAllPublicFolders ), but I can not get it to work properly for the life of me. Any help you can offer would be greatly appreciated!
Hi Diane, a while back you greatly helped me with an Outlook rule script to move an email to a network folder. Now I have to add a timestamp and can't for the life of me get it to work:
Public Sub saveAttachtoDisk3(olItem As Outlook.MailItem)
Dim olAttachment As Outlook.Attachment
Dim SaveFolder As String
SaveFolder = "\\10.33.XX.XXX\folder\Auto Email Attachments\"
Dim dateandtime As String
dateandtime = DateTime.Now.ToString("yyyy/MM/dd HH:mm:ss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & olAttachment.DisplayName
Set olAttachment = Nothing
Next
End Sub
Sub RunScript()
Dim objApp As Outlook.Application
Dim objItem As MailItem
Set objApp = Application
Set objItem = objApp.ActiveExplorer.Selection.Item(1)
saveAttachtoDisk3 objItem
End Sub
It prompts me for Object required, but I'm not sure what else is needed for it.
>> dateandtime = DateTime.Now.ToString("yyyy/MM/dd HH:mm:ss")
Is not a valid file name.
Try using this:
dateandtime = format(Now, "yyyyMMdd_HHmmss")
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & olAttachment.DisplayName
if you need to use the date at the end, you will need to get the file extension and add it.
' get the last 5 characters for the file extension
strExt = Right(olAttachment.DisplayName, 5)
olAttachment.SaveAsFile SaveFolder & "\" & olAttachment.DisplayName & dateandtime & strExt
https://www.slipstick.com/developer/code-samples/save-rename-outlook-email-attachments/
Thanks so much Diane, I notice that it appears to be maybe (?) grabbing the clock time, and was wondering if instead it could do ReceivedTime based on when Outlook is receiving it?
I checked, and both Outlook and the PC clock are both set to the same exact time UTC Eastern.
This gets the received time - dtDate = oMail.ReceivedTime
you could try omail.senton that gets you the time the sender sent it - which should only be a few seconds or so before you receive it.
Diane, if I want to get both would it look like this:
Dim olAttachment As Outlook.Attachment
Dim SaveFolder As String
SaveFolder = "xxxxxxxxxx"
Dim dateandtime As String
dtDate = oMail.ReceivedTime
Dim dtDate As Date
dateandtime = Format(Now, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & dtDate & olAttachment.DisplayName
Set olAttachment = Nothing
Sorry to bother you Diane, but would you mind telling me if the below code is scripted properly (May 20th)?
Oh, sorry. I read it as saying it that is what you got working, not asking me if it was correct. 50 lashes with a cold wet noodle. (It's hot today... a cold noodle might be refreshing, not punishment. LOL)
The code is good - but you are using 'now' not the received time in dateandtime variable - is that what you wanted? (the DIM need to be before you set the value too.)
Dim dateandtime As String
Dim dtDate As Date
dtDate = oMail.ReceivedTime
dateandtime = Format(Now, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & dtDate & olAttachment.DisplayName
If you want the filename to be the received date, use
dtDate = oMail.ReceivedTime
dateandtime = Format(dtDate, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & olAttachment.DisplayName
or for a shorter version:
dateandtime = Format( oMail.ReceivedTime, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & olAttachment.DisplayName
If you want both now and the received date, you need to format the received date.
dtDate = Format(oMail.ReceivedTime, "yyyyMMdd_HHmmss")
dateandtime = Format(Now, "yyyyMMdd_HHmmss")
For Each olAttachment In olItem.Attachments
olAttachment.SaveAsFile SaveFolder & "\" & dateandtime & dtDate & olAttachment.DisplayName
You're the best, thanks so much Diane!!!
Hi,
This is awesome, thanks!
One question: if I run the code on a lot of selected emails the code stops running after 200 emails because it seems to think I have 200 emails "open" and my system admin has set a limit on this. Is there something that can be added to the code that will effectively close each mail item after it's been saved to the file system in order to prevent this?
Thanks.
close the message after saving:
oMail.SaveAs sPath & sName, olMSG
oMail.Close olDiscard