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
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

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

*