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:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor
More Information
- How to Save Email in Windows File System
- Import Messages from File System into Outlook Folders
- OWA: Save Messages to My Documents
- Save a Message as HTML and Delete the (Annoying) Folder
- Save email message as text file
- Save Outlook Email as a PDF
- Save Selected Email Message as .msg File
- Saving All Messages to the Hard Drive Using VBA
Print Email (and Attachments) on Arrival has a list of utilities that can print messages and attachments.
Hi Diane,
is it possible to prompt for the file location on a save as dialog?
Thanks
You can use the browse for folder option in this article - https://www.slipstick.com/developer/code-samples/windows-filepaths-macro/
I have code similar to this shown below. However I am having trouble as when saving emails that have photos they are often cut-off. I can't seem to find a way to get the photos to either shrink to fit the dimensions or some other method.
I have got the pdf Outlook Item Macro to work, with change to docx with Header, as this file type is better for editing the order of embedded customer photos of documents. I need some code when the objects/items from outlook are moved to Word, before the saving. Basically customers upload images of document pages from mobiles, and the images are embedded in the email body and not classed as attachments. Most photos are oversized in the docx produced. I currently forward selected email and copy the Forwarded email body and paste H into docx and this naturally wraps all images within the margins even if in landscape. [I have a rotation macro to correct selected or all images by 90, 180 or 270 degrees, I received help from http://www.gregmaxey.com to get the two listboxes to work in a UserForm for the select or all rotation macros.] I have noticed cutting the images in the docx from the run macro and repasting with paste K, resolves the wrapping problem, but I am struggling to code this. The other problem with my manual method is that the attachments list is not included in the forwarded email body and the most recent… Read more Âğ
Thank you Diane, thank you, thank you, thank you, thank you, thank you ...
Hey Diane, Thank you for posting. Love how the code includes the headers. Having a bit of trouble. When i select items from my inbox, it saves them to the specified desktop folder. When i try to select emails from a sub folder of my outlook inbox, I run into an error "Outlook cannot save this file because it is already open elsewhere." on the following line of code: Item.SaveAs tmpFileName, olMHTML. I like saving the emails to a subfolder as i need to save them for an access review. I have an outlook rule moving ~1000 of them to the subfolder so i can group them. Any ideas? Thanks!
Hi Diane,
I have an email that has a table (or a picture) in it that gets cropped when i use this macro to save as pdf. Any suggestions to fit all data to a page in the pdf?
Hello Diane. When I have selected a confirmation (example: Accepted: invitation ...) this won't work and throw an error in here:
The error message is:
Run-time error '13': Type missmatch
I guess confirmations are a different object.
Do you know how I can fix it? I want to gather information from aa bunch of meeting confirmations.
Thanks in advance.
I get a debug error at Set objFile = FSO.CreateTextFile(tmpFileName, True) 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 & Format(Now, "yyyy-mm-dd", vbUseSystemDayOfWeek, vbUseSystem) & 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… Read more Âğ
Does it give you an error message or just stop at that line? What do you have set for the filepath?
tmpFileName = tmpFileName & Format(Now, "yyyy-mm-dd", vbUseSystemDayOfWeek, vbUseSystem) & sName & ".htm"