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.
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"
I just tried this with Outlook 2007 and Word 2003. Stepping through the code it generates the temp file, but fails to generate the pdf file. VBA isn't generating any errors and the macro happily runs to the end. Any idea what is going on?
Does it skip any lines? Is the Word version a typo? Word 2003 may not support saving as PDF.
Comment out all error handlers so it stops on errors. You may need set the editor to break on all errors - it usually only breaks on unhandled errors.
Thanks for the tip. Yes Word 2003 cannot save to pdf. Never thought to check that. So I printed to a pdf printer addin which achieves the same result. Cheers
Windows 10 was blocking it, so I used a workaround you have for it and it is working now :)
Hello Diane,
I have the same problem. it generates the temp file, but fails to generate the pdf file. VBA isn't generating any errors and the macro happily runs to the end. I've word 2016 & outlook 2016. Any suggestions what I should do?
Hello again Diane,
Is there a way to have the message saved as DOCX directly to a specified folder without any prompts?
Thanks,
Esteban R.
You can use a macro - an automatic startup macro will save all as they arrive or you can use a manual one - select the message, push a button. Either can be preconfigured to use either a hardcoded path.
Thank you, using the code what changes can I make to save it so a path?
I see:
strToSaveAs = MyDocs & "\" & sName & ".docx"
' 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 & ".docx"
End If
Not sure what to edit to change to a specified path
If you want to save to a specific path, you can change this line:
strToSaveAs = MyDocs & "\" & sName & ".docx"
to
strToSaveAs = "c:\The new path\folder\subfolder\" & sName & ".docx"
Diane thanks for the replies, I changed the code as seen below. However it still save to Documents and not the specified folder. Im guessing it has to do with the 'Mydocs = wshell.special folders' line.
--------------------------------------------------------------------------------------------
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 = "C:\Users\gonzae50\Documents\NEWVITALIZEEMAILS" & sName & ".docx"
' 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 = "C:\Users\gonzae50\Documents\NEWVITALIZEEMAILS" & sName & ".docx"
End If
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
---------------------------------------------------------------------------------------------
Do you know what I can do to get it to the folder?
Thank you SO MUCH for all the amazing help!
Just an FYI the path has all the "/" not sure why they didn't come across on the pasting of the code.
It's wordpress - or, more accurately php - it removes the slashes. :(
You aren't using mydocs. or shouldn't be. Comment out or delete that line and see if it errors. Do you have a slash after the folder name ? This: Documents\NEWVITALIZEEMAILS" & sName & ".docx" = Documents\NEWVITALIZEEMAILSsname.docx
Use a trailing slash in the strtosaveas path: Documents\NEWVITALIZEEMAILS\"