Save Messages from Outlook

Many people access the material from this web site daily. Most just take what they want and run. That's OK, provided they are not selling on the material as their own; however if your productivity gains from the material you have used, a donation from the money you have saved would help to ensure the continued availability of this resource. Click the appropriate button above to access PayPal.

Save messages from Outlook to Windows files

On several occasions I have answered forum questions from people who want to save e-mail messages, received in Outlook, to Windows files on their hard drives. To save repeating myself again, I have posted the code below.

The SaveSelected macro will save selected messages to a named folder - initially set as:

C:\Outlook Message Backup\

though this may be changed to suit user preferences. If the folder is not present the process will create it.

The main macro 'SaveItem' may be used as a script associated with an Outlook rule to process messages identified by the rule as they arrive.

If Outlook rules dialog does not display the option to run a script, it is an indication that a security setting is in force. You can address this with a registry hack:

1. Click Start - Search, type ‘regedit’ (Note: there are no quotation marks in the command.) and press Enter.

2. Navigate to HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Security. (where 16 is the Office version - here 2016)

3. Right-click a blank area, create a new DWORD Value named as ‘EnableUnsafeClientMailRules’ and set it to 1.

Alternatively you could run the following macro to apply the registry setting described.

Sub SetOutlookSecurityKey()
Dim WSHShell As Object
Dim rKeyWord As String
Dim wVer As String
Dim RegKey As String
Dim strItem As String
strItem = "EnableUnsafeClientMailRules"
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Outlook\Security\"
Debug.Print RegKey
End
Set WSHShell = CreateObject("WScript.Shell")
Start:
On Error Resume Next
rKeyWord = WSHShell.RegRead(RegKey & strItem)
Select Case rKeyWord
Case Is = "1"
MsgBox "Outlook Rules Security Check is Off"
Case Else
WSHShell.RegWrite RegKey & strItem, 1, "REG_DWORD"
MsgBox "Outlook Rules Security Check is Off"
End Select
lbl_Exit:
Exit Sub
End Sub

The filename is configured in the section of the SaveSelected macro (below).

If olItem.Sender Like "*@gmayor.com" Then 'Replace with your domain
    fName = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
    Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject
Else
    fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
    Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject
End If

Note the first part features my domain name. This should be changed to the domain name you mail from. If you use a domain name that may be shared by many users such as gmail.com, then you will have to put your e-mail address there. This is to allow you to save messages that you sent as well as those you receive.

If you only wish to save messages you receive, then lose the whole of that section and replace with

fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject

The process always creates unique filenames, so there is no danger of duplicated file names being overwritten and the length of the filename, without its msg extension is limited to 100 characters (again you can change that if you wish).

fName = Left(fName, 100)

The process for creating macros from listings in Outlook is much like that for Word, covered at https://www.gmayor.com/installing_macro.htm however recent versions of Outlook have beefed up security and you will almost certainly need to self certify your code, which is easier said than done. The following link explains how to do that to ensure that it works. https://www.gmayor.com/create_and_employ_a_digital_cert.htm

Option Explicit

Sub SaveSelected()
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim olItem As Object
For Each olItem In Application.ActiveExplorer.Selection
If olItem.Class = OlObjectClass.olMail Then
SaveItem olItem
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Sub SaveItem(olItem As MailItem)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim fName As String
Dim fPath As String
fPath = "C:\Outlook Message Backup\" 'Change as required
CreateFolders fPath

If olItem.Sender Like "*@gmayor.com" Then 'Replace with your domain
fName = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject
Else
fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject
End If
fName = Replace(fName, Chr(58) & Chr(41), "")
fName = Replace(fName, Chr(58) & Chr(40), "")
fName = Replace(fName, Chr(34), "-")
fName = Replace(fName, Chr(42), "-")
fName = Replace(fName, Chr(47), "-")
fName = Replace(fName, Chr(58), "-")
fName = Replace(fName, Chr(60), "-")
fName = Replace(fName, Chr(62), "-")
fName = Replace(fName, Chr(63), "-")
fName = Replace(fName, Chr(124), "-")
fName = Left(fName, 100)
SaveUnique olItem, fPath, fName
lbl_Exit:
Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
lngF = 1
lngName = Len(strFileName)
Do While fso.FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
lbl_Exit:
Set fso = Nothing
Exit Function
End Function

Save Messages

Save your Outlook messages to windows files in msg format.

Graham Mayor

... helping to ease the lives of Microsoft Word users.

You appear to be using ad blocking software. While I respect your right to do so, please be aware that the minimal advertising on this site helps defray the cost of providing this facility, and I would therefore ask that you turn off the blocker while browsing this site.

Save messages from Outlook to Windows files

Save Messages