Save emails from Outlook as .msg with dates

To save individual emails from Microsoft Outlook to .msg format you can simply select required emails and drag them to any folder or to your desktop. The only issue I have with this approach is that each .msg file name is made up of only of email subject and sometimes a number (to avoid conflicts on emails with the same subject line). File created and modified dates are the export date. All this means that there is no way to arrange emails in date sent / received order. This may be not a problem is you have only couple of emails to export, but with larger number of emails it quickly becomes very disorganised.

I recently came across a small neat VBS Macro that I found on www.slipstick.com. When run it exports selected emails into .msg files and adds date / time received as a prefix to the file names.
For example, where you would normally have email with file name: Phone Call.msg, now you have 2014.12.21-14.12.04 – Phone Call.msg.

Bellow is the code I used. This is almost exactly the same code as in the above linked website, I just changed date/time formatting to make it more human readable.

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, "yyyy.mm.dd", vbUseSystemDayOfWeek, _
 vbUseSystem) & Format(dtDate, "-hh.nn.ss", _
 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

Emails are saved in “Documents” folder inside user’s profile. I.e. C:\Users\<user.name>\Documents. This is not necessary the same as user’s “My documents” folder determined by settings in Libraries or Group Policy.

Another thing to note is that this macro will override files with the same name. This means that if you have multiple emails with the same subject line that were sent / received at exactly the same time (within 1 second), only one of these emails will be saved. In most cases such emails would be duplicates anyway, but you may want to check if number selected and exported emails matches.

2015.01
Outlook 2010