Save Outlook Email as a PDF

There are two ways to save Outlook messages in PDF format: by printing to a PDF printer or saving in PDF format from Word. This sample shows how to use the Word Object Model to save as PDF. (There is a third way: use Adobe Acrobat's package feature. It makes a really nice PDF archive, if you own Acrobat.)

This code sample will save one or more selected Outlook email messages as a PDF file. Because it uses Word object to save, this code could easily be tweaked to save messages in any format Word can save as.

Don't forget to set a reference to the Word object library in Tools > References. Select the correct version for your version of Office. (Most people will only have one entry, the correct one.)

A version of this macro to use in a run a script rule is here.

Sub SaveMessageAsPDF()
     
    Dim Selection As Selection
    Dim obj As Object
    Dim Item As MailItem
     
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Set Selection = Application.ActiveExplorer.Selection

For Each obj In Selection
 
    Set Item = obj
    
    Dim FSO As Object, TmpFolder As Object
    Dim sName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set tmpFileName = FSO.GetSpecialFolder(2)
    
    sName = Item.Subject
    ReplaceCharsForFileName sName, "-"
    tmpFileName = tmpFileName & "\" & sName & ".mht"
    
    Item.SaveAs tmpFileName, olMHTML
    
    
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=True)
  
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Set WshShell = CreateObject("WScript.Shell")
    MyDocs = WshShell.SpecialFolders(16)
       
strToSaveAs = MyDocs & "\" & sName & ".pdf"
 
' check for duplicate filenames
' if matched, add the current time to the file name
If FSO.FileExists(strToSaveAs) Then
   sName = sName & Format(Now, "hhmmss")
   strToSaveAs = MyDocs & "\" & sName & ".pdf"
End If
  
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
    strToSaveAs, 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
             
Next obj
    wrdDoc.Close
    wrdApp.Quit
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set WshShell = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set Item = Nothing
 
End Sub
 
' This function removes invalid and other characters from file names
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, Chr(34), sChr)
  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, " ", sChr)
  sName = Replace(sName, "{", sChr)
  sName = Replace(sName, "[", sChr)
  sName = Replace(sName, "]", sChr)
  sName = Replace(sName, "}", sChr)
  sName = Replace(sName, "!", sChr)
End Sub

Save without the Headers

This version of the macro saves the message without the short To/From/subject headers normally found at the top of a printed message.

Sub SaveMessageAsPDF()
     
'Set up the browser
    Dim browser As String
    Dim ConvertMail As Boolean
    Dim CheckHTML As Boolean
    browser = "C:\Program Files\Internet Explorer\iexplore.exe"
    ConvertMail = False
    CheckHTML = True
     
    Dim Selection As Selection
    Dim obj As Object
    Dim Item As MailItem
     
 
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Set Selection = Application.ActiveExplorer.Selection

For Each obj In Selection
 
    Set Item = obj
    
    Dim FSO As Object, TmpFolder As Object
    Dim sName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set tmpFileName = FSO.GetSpecialFolder(2)
    
    sName = Item.Subject
    ReplaceCharsForFileName sName, "-"
    tmpFileName = tmpFileName & "\" & sName & ".htm"
    

 Dim ConvertHTML As Boolean
    ConvertHTML = True

    If Item.BodyFormat = olFormatHTML And ConvertMail = False Then
        Dim rawHTML As String
        rawHTML = Item.HTMLBody

        If CheckHTML = False Then
            ConvertHTML = False
        Else
            If InStr(UCase(rawHTML), UCase("src=""cid:")) = 0 Then
                ConvertHTML = False
            End If
        End If
    End If
     If ConvertHTML = False Then
            Set objFile = FSO.CreateTextFile(tmpFileName, True)
            objFile.Write "" & rawHTML
            objFile.Close
            Set objFile = Nothing
    Else
            Item.SaveAs tmpFileName, olHTML
    End If
   
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=True)
  
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Set WshShell = CreateObject("WScript.Shell")
    MyDocs = WshShell.SpecialFolders(16)
       
strToSaveAs = MyDocs & "\" & sName & ".pdf"
 
' check for duplicate filenames
' if matched, add the current time to the file name
If FSO.FileExists(strToSaveAs) Then
   sName = sName & Format(Now, "hhmmss")
   strToSaveAs = MyDocs & "\" & sName & ".pdf"
End If
  
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
    strToSaveAs, 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
             
Next obj
    wrdDoc.Close
    wrdApp.Quit
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set WshShell = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set Item = Nothing
 
End Sub
 
' This function removes invalid and other characters from file names
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, Chr(34), sChr)
  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, " ", sChr)
  sName = Replace(sName, "{", sChr)
  sName = Replace(sName, "[", sChr)
  sName = Replace(sName, "]", sChr)
  sName = Replace(sName, "}", sChr)
  sName = Replace(sName, "!", sChr)
End Sub

Save as a DOCX File

To save the message as a Word Document using the DOCX file type, replace the code blocks that saves as a pdf with the code below.

wrdApp.ActiveDocument.SaveAs2 FileName:= _
        strToSaveAs, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=15

How to Use Macros

First: You will need macro security set to low during testing.

To check your macro security in Outlook 2010 and above, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s 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.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To put the code in a module:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

More information as well as screenshots are at How to use the VBA Editor