businessmen with frosties

The Official Blog of Matthiew Morin :: A withani.net Production

Outlook Macro: Save Incoming Messages and Attachments to Hard Drive


Outlook archives (.PSTs) have been the bane of my existence during my years being a help desk tech.  Outlook was never originally designed to be a filing cabinet, yet people continue to use it as one (myself included).

This macro (code below) is designed to save incoming messages and any attachments into a specific folder structure on a hard drive, network drive or flash drive.  Currently the structure is set to “C:\email\companyDomain\Year\Month\yyyymmdd_emailsubject.pdf” however this can be changed easily, in the save location area in the code.

I’ve found that this macro works best if you set a rule in Outlook to run it only from certain senders or domains.  For example: I may not want any emails from gmail accounts to go into this folder structure but I may want emails from my work domain to get saved.

I would also recommend doing this due to performance issues; in order to save the message as a PDF the macro has to launch and instance of Microsoft Word in the background but by all means it is a simple code modification to save the incoming message in an Outlook .msg format.

Disclaimer: My code is very sloppy; I appreciate any feedback or tweaks anybody can find.

'#####################################
'### Outlook Save As Macro         ###
'### Developed by: Matthiew Morin  ###
'### Created: April 2013           ###
'### Version: 1.0                  ###
'### Contact: matt@withani.net     ###
'#####################################

Sub SaveAsMsg(MyMail As MailItem)
' requires reference to Microsoft Scripting Runtime
' \Windows\System32\Scrrun.dll
' Also requires reference to Microsoft Word Object Library
Dim fso As FileSystemObject
Dim strSubject As String
Dim strSaveName As String
Dim blnOverwrite As Boolean
Dim strFolderPath As String
Dim looper As Integer
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim oMail As Outlook.MailItem

strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)

'Get Sender email domain
sendEmailAddr = oMail.SenderEmailAddress
companyDomain = Right(sendEmailAddr, Len(sendEmailAddr) - InStr(sendEmailAddr, "@"))

' ### USER OPTIONS ###
blnOverwrite = False ' False = don't overwrite, True = do overwrite

'### THIS IS WHERE SAVE LOCATIONS ARE SET ###
bPath = "C:\email\" 'Defines the base path to save the email
cPath = bPath & companyDomain & "\" 'Adds company domain to base path
yPath = cPath & Format(Now(), "yyyy") & "\" 'Add year subfolder
mPath = yPath & Format(Now(), "MMMM") & "\" 'Add month subfolder

'### Path Validity ###
If Dir(bPath, vbDirectory) = vbNullString Then
    MkDir bPath
End If
If Dir(cPath, vbDirectory) = vbNullString Then
    MkDir cPath
End If
If Dir(yPath, vbDirectory) = vbNullString Then
    MkDir yPath
End If

'### Get Email subject & set name to be saved as ###
emailSubject = CleanFileName(oMail.Subject)
saveName = Format(oMail.ReceivedTime, "yyyymmdd") & "_" & emailSubject & ".mht"
Set fso = CreateObject("Scripting.FileSystemObject")

'### If don't overwrite is on then ###
If blnOverwrite = False Then
    looper = 0
    Do While fso.FileExists(yPath & saveName)
        looper = looper + 1
        saveName = Format(oMail.ReceivedTime, "yyyymmdd") & "_" & emailSubject & "_" & looper & ".mht"
        pdfSave = Format(oMail.ReceivedTime, "yyyymmdd") & "_" & emailSubject & "_" & looper & ".pdf"
        Loop
Else '### If don't overwrite is off, delete the file ###
    If fso.FileExists(yPath & saveName) Then
        fso.DeleteFile yPath & saveName
    End If
End If
oMail.SaveAs yPath & saveName, olMHTML
pdfSave = yPath & Format(oMail.ReceivedTime, "yyyymmdd") & "_" & emailSubject & ".pdf"

'### Open Word to convert file to PDF ###
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")

Set wrdDoc = wrdApp.Documents.Open(FileName:=yPath & saveName, Visible:=True)
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
            pdfSave, ExportFormat:= _
            wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
            wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _
            Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
            CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
            BitmapMissingFonts:=True, UseISO19005_1:=False

wrdDoc.Close
wrdApp.Quit

'### Clean up files ###
With New FileSystemObject
    If .FileExists(yPath & saveName) Then
        .DeleteFile yPath & saveName
    End If
End With

'### If Mail Attachments: clean file name, save into path ###
If oMail.Attachments.Count > 0 Then
    For Each atmt In oMail.Attachments
        atmtName = CleanFileName(atmt.FileName)
        atmtSave = yPath & Format(oMail.ReceivedTime, "yyyymmdd") & "_" & atmtName
        atmt.SaveAsFile atmtSave
    Next
End If

Set oMail = Nothing
Set olNS = Nothing
Set fso = Nothing
End Sub

Function CleanFileName(strText As String) As String
 Dim strStripChars As String
Dim intLen As Integer
Dim i As Integer
strStripChars = "/\[]:=," & Chr(34)
intLen = Len(strStripChars)
strText = Trim(strText)
For i = 1 To intLen
strText = Replace(strText, Mid(strStripChars, i, 1), "")
Next
CleanFileName = strText
End Function

Here is another code sample to save the message as a native .MSG rather than a PDF. It runs a bit more quickly and is compatible to open in Outlook.

'#####################################
'### Outlook Save As Macro ###
'### Developed by: Matthiew Morin ###
'### Created: May 2014 ###
'### Version: 1.0 (.msg) ###
'### Contact: matt@withani.net ###
'#####################################
 
Sub SaveAsMsg(MyMail As MailItem)
' requires reference to Microsoft Scripting Runtime
' \Windows\System32\Scrrun.dll
' Also requires reference to Microsoft Word Object Library
Dim fso As FileSystemObject
Dim strSubject As String
Dim strSaveName As String
Dim blnOverwrite As Boolean
Dim strFolderPath As String
Dim looper As Integer
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim oMail As Outlook.MailItem
 
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set oMail = olNS.GetItemFromID(strID)
 
'Get Sender email domain
sendEmailAddr = oMail.SenderEmailAddress
companyDomain = Right(sendEmailAddr, Len(sendEmailAddr) - InStr(sendEmailAddr, "@"))
 
' ### USER OPTIONS ###
blnOverwrite = False ' False = don't overwrite, True = do overwrite
 
'### THIS IS WHERE SAVE LOCATIONS ARE SET ###
'Currently only saves to yPath. Change the yPath variable to mPath in other areas of the script to enable the month folder.
bPath = "C:\email\" 'Defines the base path to save the email
cPath = bPath & companyDomain & "\" 'Adds company domain to base path
yPath = cPath & Format(Now(), "yyyy") & "\" 'Add year subfolder
mPath = yPath & Format(Now(), "MMMM") & "\" 'Add month subfolder
 
'### Path Validity ###
'Make sure base path exists
If Dir(bPath, vbDirectory) = vbNullString Then
   MkDir bPath
End If
'Make sure company domain path exists
If Dir(cPath, vbDirectory) = vbNullString Then
   MkDir cPath
End If
'Make sure year path exists
If Dir(yPath, vbDirectory) = vbNullString Then
   MkDir yPath
End If
'Make sure month path exists (uncomment below lines to enable)
'If Dir(mPath, vbDirectory) = vbNullString Then
 ' MkDir mPath
'End If

'### Get Email subject & set name to be saved as ###
emailSubject = CleanFileName(oMail.Subject)
saveName = Format(oMail.ReceivedTime, "yyyymmdd") & "_" & emailSubject & ".msg"
Set fso = CreateObject("Scripting.FileSystemObject")
 
'### If don't overwrite is on then ###
If blnOverwrite = False Then
   looper = 0
   Do While fso.FileExists(yPath & saveName)
      looper = looper + 1
      saveName = Format(oMail.ReceivedTime, "yyyymmdd") & "_" & emailSubject & "_" & looper & ".msg"
   Loop
Else '### If don't overwrite is off, delete the file ###
   If fso.FileExists(yPath & saveName) Then
      fso.DeleteFile yPath & saveName
   End If
End If

'### Save MSG File ###
oMail.SaveAs yPath & saveName, olMSG 
 
'### If Mail Attachments: clean file name, save into path ###
If oMail.Attachments.Count > 0 Then
   For Each atmt In oMail.Attachments
      atmtName = CleanFileName(atmt.FileName)
      atmtSave = yPath & Format(oMail.ReceivedTime, "yyyymmdd") & "_" & atmtName
      atmt.SaveAsFile atmtSave
   Next
End If
 
Set oMail = Nothing
Set olNS = Nothing
Set fso = Nothing
End Sub
 
Function CleanFileName(strText As String) As String
Dim strStripChars As String
Dim intLen As Integer
Dim i As Integer
strStripChars = "/\[]:=," & Chr(34)
intLen = Len(strStripChars)
strText = Trim(strText)
For i = 1 To intLen
strText = Replace(strText, Mid(strStripChars, i, 1), "")
Next
CleanFileName = strText
End Function
Category: Misc.
  • beginner says:

    Hi Mat, when I want to run this macro nothing happens in outlook so what should I do now?

    April 14, 2014 at 7:39 am
    • Matthiew Morin says:

      Hi there!

      As mentioned in the post, this macro works best when set as a rule in Outlook for incoming messages. Meaning that it wasn’t designed to run against an entire inbox or “on-demand”.

      Here’s what the text of my Outlook rule looks like:

      Apply this rule after the message arrives
      from [EMAIL ADDRESSES]
      and on this machine only
      run Project1.SaveAsMSG

      Can you ensure that your rule is properly set in Outlook?

      April 14, 2014 at 10:27 am
      • beginner says:

        Sorry if my question seems not well-done, I asked it because I am new in outlook macro, I worked with excel macros and when we write a macro and press run it runs it but I wanted to test your macro and I could not run that macro and even outlook did not show it in macros list.

        April 14, 2014 at 1:29 pm
        • Matthiew Morin says:

          Correct, Outlook macros function a little bit differently than Excel macros. To create an Outlook macro (I’m using 2007), click Tools -> Macro -> Visual Basic Editor.

          You should be able to copy and paste the code into there which will in turn create a VBA project called Project1.SaveAsMsg. Once this project is created, you will be able to access it from the Outlook Rules Wizard where you can set the parameters that will trigger the macro. Once this rule is created you can run it on demand as well as have it run as messages enter that meet the rule’s criteria.

          April 16, 2014 at 3:03 pm
  • Julia Petersen says:

    Good Morning Matthew,

    I was wanting to use your wonderful script to save the emails as an .msg file, then save the .msg files in a folder on my shared drive. Where in your macro can I change the file saving format and the folder location?

    May 15, 2014 at 10:57 am
    • Matthiew Morin says:

      Hi Julia,

      Sorry for the delayed response. I updated the post with a second set of code that will save the messages as the native MSG format.

      In regards to changing the folder location, those locations are manipulated around line 35 or 36 by changing the bPath (Base Path), cPath (Company Path), yPath (Year Path), mPath (Month Path) variables. For example, if I wanted to save my emails in a folder named “emails” on a drive labelled X:\, I would change my bPath variable to “X:\emails”.

      I hope this helps you.

      May 19, 2014 at 2:00 pm

Your email address will not be published. Required fields are marked *

*