Pete Hinchley: A Macro to Export Multiple Emails and their Attachments from Microsoft Outlook to a Single PDF

I recently developed a VBA macro for Microsoft Outlook 2016 that would allow a user to export one or more emails, and their attachments, to a single consolidated PDF document.

I wrote the macro because no third-party offering appeared to provide this capability. Adobe Acrobat provides similar functionality, but attachments, instead of being “expanded”, are embedded as links within the generated PDF.

There are two core components to the solution:

Note: If you intend to recreate this solution using the code shown below, the ProgressBox user form requires the ShowModal property to be set to False. You will also need to add the following VBA references to the macro:

The operation of the macro is relatively straightforward. The macro entry point is a method named ExportToPdf. This method performs the following high-level tasks:

The following attachment file types are supported:

The code is dependent on the installation of Microsoft Office 2016 and Adobe Acrobat DC. Earlier versions of Office would also work, but the library references would need to be changed accordingly.

The first iteration of this solution did not have a dependency on Adobe Acrobat DC, as the document merging process was managed in Word, and the resultant document was saved as a PDF. However, after further testing, it was discovered that this process did not always work, as some PDF documents could not be opened by Word. Hence, the code was rewritten to save all documents as PDFs using Word, with Acrobat used to merge the documents into a consolidated PDF. This process is more complicated to implement, and adds a dependency on Acrobat, but in theory, it is a better solution, as under the original solution, PDF attachments were double-handled (converted to Word, and then back to PDF).

This is the code for the Export module:

' Purpose: Save selected emails, and their attachments, to a PDF.

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function CoAllowSetForegroundWindow Lib "ole32.dll" (ByVal pUnk As Object, ByVal lpvReserved As Long) As Long

Dim Namespace As Namespace
Dim FileSystemObject As FileSystemObject
Dim SelectedEmails As Selection
Dim SavedFiles As Collection
Dim FilesToMerge As Collection
Dim WordApp As Word.Application
Dim ExcelApp As Excel.Application

' Regular expressions defining the attachments that will be processed.
' All other attachments will be ignored.
Const ExcelExtensionsRegExp = "^(xl(s|sx|sm|t|tm|tx))$"
Const ImageExtensionsRegExp = "^(jpg|jepg|png|gif|bmp|tiff?)$"
Const OtherExtensionsRegExp = "^(do(c|cx|cm|t|tm|tx)|pdf|txt)$"
Const MessageExtensionsRegExp = "^(msg)$"

Sub ExportToPdf()
  ' Exit if the user has not selected at least one email.
  If (Outlook.ActiveExplorer.Selection.Count = 0) Then
    MsgBox "Please select one or more emails.", vbInformation + vbOKOnly
    Exit Sub
  End If

  Set Namespace = Application.GetNamespace("MAPI")
  Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
  Set SelectedEmails = Outlook.ActiveExplorer.Selection

  Set SavedFiles = New Collection
  Set FilesToMerge = New Collection

  Set WordApp = New Word.Application
  WordApp.Visible = False

  ' Allow Word to take focus. Required to ensure the Save As dialog comes to the foreground.
  CoAllowSetForegroundWindow WordApp, 0

  ' Backup the "warn before saving" option.
  WarnBeforeSaveOption = WordApp.Options.WarnBeforeSavingPrintingSendingMarkup

  ' Disable the option.
  WordApp.Options.WarnBeforeSavingPrintingSendingMarkup = False

  Set ExcelApp = Nothing

  ' The path where the generated PDF will be saved.
  PdfPath = GetPdfPath

  ' Exit if no path is specified for saving the PDF.
  ' This will occur if the user closes the 'File Save As' dialog without providing a valid path.
  If PdfPath = "" Then
    ' Word is used to display the 'File Save As' dialog.
    ' Close Word before exiting.
    WordApp.Quit
    Exit Sub
  End If

  ' The path to the folder where all temporary documents, and the final PDF, will be saved.
  SavePath = Left(PdfPath, InStrRev(PdfPath, "\"))

  ' Initialise the progress bar component.
  ProgressBox.Show
  ProgressBox.Increment 0, "Exporting..."

  ' Save the selected emails, and their attachments, to the file system.
  SaveEmails SelectedEmails, SavePath

  ' Convert each of the saved files to PDF documents.
  ConvertDocumentsToPdf

  ' Merge the PDF documents into a single PDF document.
  MergePdfDocuments PdfPath

  ' Indicate the export is complete.
  ProgressBox.Increment 100, "Complete!"

  ' Show the completion dialog for 1 second.
  Sleep 1000
  ProgressBox.Hide

  ' Reinstate the old "warn before save" option.
  WordApp.Options.WarnBeforeSavingPrintingSendingMarkup = WarnBeforeSaveOption

  ' Close Word (and Excel, if it was used to process attachments).
  WordApp.Quit
  If Not (ExcelApp Is Nothing) Then
    ExcelApp.DisplayAlerts = True
    ExcelApp.Quit
  End If

  ' Clean up.
  Set SavedFiles = Nothing
  Set FilesToMerge = Nothing
  Set SelectedEmails = Nothing
  Set FileSystemObject = Nothing
  Set Namespace = Nothing
End Sub

Function GetPdfPath()
  ' The easiest way to retrieve a file save path is via the GetSaveAsFilename method in Excel.
  ' Unfortunately, this method isn't available in Word.
  ' As this macro always requires Word, but only requires Excel when exporting an Excel attachment,
  ' it makes sense to avoid using Excel to retrieve the file save path.
  ' Hence we use the (slightly more convoluted) FileDialog method.
  Set Dialog = WordApp.FileDialog(msoFileDialogSaveAs)
  With Dialog
    .InitialFileName = Environ("USERPROFILE") & "\"
    .FilterIndex = 7 ' *.pdf - the 7th option in the drop down list box of file formats.
    .Title = "Save As"
    If .Show <> 0 Then
      GetPdfPath = .SelectedItems(1)
    Else
      GetPdfPath = ""
    End If
  End With
End Function

Private Sub SaveEmails(SelectedEmails, SavePath)
  ' Used to update the progress bar.
  Counter = 0

  ' Iterate through each of the selected emails.
  For Each SelectedEmail In SelectedEmails
    ' Update the progress indicator (pausing each time for 250ms to ensure the progression is noticeable).
    ProgressBox.Increment (Counter / SelectedEmails.Count) * 100, "Exporting..."
    Sleep 250

    ' Retrieve the details of the current email.
    EntryID = SelectedEmail.EntryID
    Set Email = Namespace.GetItemFromID(EntryID)

    SaveEmail Email, SavePath

    ' Increment the counter that is used to update the progress indicator.
    Counter = Counter + 1

    Set Email = Nothing
  Next SelectedEmail
End Sub

Private Sub SaveEmail(Email, SavePath)
  ' The full path used for saving the email to the file system.
  ' The document name is based on the time the email was received.
  Path = SavePath & (Int(Rnd * 100000)) & Format(Email.CreationTime, "yyyyMMddhhmmss") & ".doc"

  ' Delete any previous copy of the email from the file system.
  ' This is only necessary if the email was previously exported, but not properly cleaned up (e.g. the previous export failed).
  If FileSystemObject.FileExists(Path) Then
    FileSystemObject.DeleteFile Path
  End If

  ' Record (in a collection named SaveFiles) the path to the saved email.
  ' This collection will be subsequently used to retrieve a list of the files that need to be merged.
  SavedFiles.Add Path

  ' Save the email to the file system.
  Email.SaveAs Path, olDoc

  ' Resize images in the email.
  Set Document = WordApp.Documents.Open(FileName:=Path, Visible:=False)
  If Document.InlineShapes.Count > 0 Then
    ResizeImages Document
  End If
  Document.SaveAs2 Path, wdFormatXMLDocument
  Document.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False

  ' The following block is only executed if the email includes attachments.
  If Email.Attachments.Count > 0 Then
    ' Iterate through all attachments.
    For Each Attachment In Email.Attachments
      ' Extract the extension of each attachment.
      Extension = GetFileExtension(Attachment.FileName)

      ' Inline images are saved with the email, and do not need to be processed as separate attachments.
      If IsEmbeddedAttachment(Attachment) And IsImage(Extension) Then
        GoTo NextIteration
      End If

      ' Only attachments matching the whitelist of approved types are processed.
      If IsValidAttachment(Extension) Then
        ' The attachment is saved to the file system (using the attachment file name).
        AttachmentPath = Truncate(SavePath & (Int(Rnd * 100000)) & Attachment.FileName)
        Attachment.SaveAsFile AttachmentPath

        ' Additional processing is applied to Excel attachments.
        If IsExcelDocument(Extension) Then
          ' Start Excel if it isn't already running (i.e. this is the first Excel attachment).
          If ExcelApp Is Nothing Then
            Set ExcelApp = New Excel.Application
            ExcelApp.Visible = False
            ExcelApp.DisplayAlerts = False
          End If

          ' The path to the new Word document that will be used for storing the content within the Excel document.
          FilePath = Truncate(GetBaseFilePath(AttachmentPath) & (Int(Rnd * 100000)) & ".docx")

          ' Create a new blank Word document.
          Set TempDocument = WordApp.Documents.Add("Normal", False, wdNewBlankDocument, False)

          ' Open the Excel document.
          Set Workbook = ExcelApp.Workbooks.Open(AttachmentPath)

          ' Iterate through all worksheets in the Excel document.
          For Each Worksheet In Workbook.Worksheets
            ' Copy the content within the worksheet.
            Worksheet.UsedRange.Copy

            ' Add a new section to the target Word document.
            Set Section = TempDocument.Sections.Add

            ' Paste the copied content into the Word document.
            Section.Range.PasteAndFormat wdFormatOriginalFormatting
          Next Worksheet

          ' Delete the first section of the temporary Word document.
          ' This removes the blank page that is created at the beginning of the document when the first section is added.
          TempDocument.Sections.Item(1).Range.Delete wdCharacter, 1

          ' Save the temporary Word document.
          TempDocument.SaveAs2 FilePath, wdFormatXMLDocument
          TempDocument.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False

          ' Close and then delete the Excel document.
          Workbook.Close False
          Kill AttachmentPath

          ' The attachment path is no longer the path to the saved Excel document;
          ' it's now the path to the Word document into which the Excel content was copied.
          AttachmentPath = FilePath
        ElseIf IsEmailMsg(Extension) Then
          ' Attachment is an Msg.
          Set Msg = Application.CreateItemFromTemplate(AttachmentPath)
          SaveEmail Msg, SavePath
          Kill AttachmentPath

          GoTo NextIteration
        End If

        ' Record the path to the saved attachment.
        SavedFiles.Add AttachmentPath
      End If

NextIteration:
    Next Attachment
  End If
End Sub

'Helper function to ensure path lengths are unique and don't exceed 250 characters.
Function Truncate(Path)
  ' Maximum number of characters in a file path.
  MaxPathLength = 250

  ' Length of current path.
  PathLength = Len(Path)

  If PathLength > MaxPathLength Then
    Extension = GetFileExtension(Path)
    ' Truncate base file path such that when the extension is re-added, the max path length is not exceeded.
    Truncate = Left(GetBaseFilePath(Path), MaxPathLength - Len(Extension) + 1) & "." & Extension
  Else
    Truncate = Path
  End If
End Function

' Helper function to retrieve the extension of a file. e.g. FooBar.pdf = pdf
Function GetFileExtension(FileName)
  GetFileExtension = LCase(FileSystemObject.GetExtensionName(FileName))
End Function

' Helper function to check if an attachment is embedded (OLE) within an email.
' We typically want to ignore embedded attachments as they are automatically included when an email is saved.
Function IsEmbeddedAttachment(Attachment)
  Set PropertyAccessor = Attachment.PropertyAccessor
  Property = PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001E")
  IsEmbeddedAttachment = InStr(1, Property, "@")
End Function

' Helper function to check if a string (subject) matches a regular expression pattern.
Function TestRegExp(Subject, Pattern)
  Set RegExp = New RegExp
  With RegExp
    .Global = True
    .IgnoreCase = True
    .Pattern = Pattern
  End With
  TestRegExp = RegExp.Test(Subject)
End Function

' Helper function to check if an attachment is an image (based on file extension).
Function IsImage(Extension)
  IsImage = TestRegExp(Extension, ImageExtensionsRegExp)
End Function

' Helper function to check if an attachment is an Excel document (based on file extension).
Function IsExcelDocument(Extension)
  IsExcelDocument = TestRegExp(Extension, ExcelExtensionsRegExp)
End Function

' Helper function to check if an attachment is an Outlook email (based on file extension).
Function IsEmailMsg(Extension)
  IsEmailMsg = TestRegExp(Extension, MessageExtensionsRegExp)
End Function

' Helper function to check if an attachment, other than an image or Excel document, is whitelisted (based on file extension).
Function IsOtherValidDocument(Extension)
  IsOtherValidDocument = TestRegExp(Extension, OtherExtensionsRegExp)
End Function

' Helper function to check if an attachment is a PDF (based on file extension).
Function IsPdfDocument(Path)
  IsPdfDocument = TestRegExp(Path, "\.pdf$")
End Function

' Helper function to check if an attachment is whitelisted (based on file extension).
Function IsValidAttachment(Extension)
  IsValidAttachment = IsImage(Extension) Or IsExcelDocument(Extension) Or IsEmailMsg(Extension) Or IsOtherValidDocument(Extension)
End Function

' Helper function to get the path to a file without the file's extension.
Function GetBaseFilePath(Path)
  Extension = "." & GetFileExtension(Path)
  GetBaseFilePath = Replace(Path, Extension, "")
End Function

' Used to convert all emails and their associated attachments to PDF documents.
Private Sub ConvertDocumentsToPdf()
  ' Initialise the progress bar component.
  ' This resets the progress bar after saving emails and attachments to the file system.
  ProgressBox.Increment 0, "Converting..."
  Counter = 0

  ' Iterate through the emails and attachments that were saved to the file system.
  For Each SavedFile In SavedFiles
    ProgressBox.Increment (Counter / SavedFiles.Count) * 100, "Converting..."
    Sleep 250

    ' No processing required for native PDF document.
    If IsPdfDocument(SavedFile) Then
      FilesToMerge.Add SavedFile
    Else
      NewPdfPath = GetBaseFilePath(SavedFile) & ".pdf"

      ' Check if the saved document is an image.
      If IsImage(GetFileExtension(SavedFile)) Then
        ' Create a new blank Word document.
        Set Document = WordApp.Documents.Add("Normal", False, wdNewBlankDocument, False)

        ' Insert the image as a shape into the new consolidated document.
        InsertImage SavedFile, Document
      Else
        ' Open the document in Word.
        Set Document = WordApp.Documents.Open(FileName:=SavedFile, Visible:=False)
      End If

      ' Save the Word document as a PDF.
      Document.SaveAs2 NewPdfPath, wdFormatPDF

      ' Close Word.
      Document.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False

      ' Store the path to the collection of PDF documents to be merged.
      FilesToMerge.Add NewPdfPath

      ' Delete the saved document after it has been converted to a PDF.
      Kill SavedFile
    End If

    Counter = Counter + 1
  Next SavedFile
End Sub

' Resize inline images so that they don't extend beyond the borders of the page.
Sub ResizeImages(Document)
  ' Get page dimensions. Give some wiggle room.
  PageHeight = Document.PageSetup.PageHeight - (Document.PageSetup.TopMargin + Document.PageSetup.BottomMargin + 50)
  PageWidth = Document.PageSetup.PageWidth - (Document.PageSetup.LeftMargin + Document.PageSetup.RightMargin + Document.PageSetup.Gutter + 50)

  For i = 1 To Document.InlineShapes.Count
    ' Check if the current shape is a picture.
    If Document.InlineShapes.Item(i).Type = wdInlineShapePicture Or Document.InlineShapes.Item(i).Type = wdInlineShapeLinkedPicture Then
      Set Shape = Document.InlineShapes.Item(i)
      Shape.Range.Select
      Shape.LockAspectRatio = msoFalse

      ' Constrain the shape dimensions to fit within the page.
      If (Shape.Width > PageWidth) Then
        If ((PageWidth / Shape.Width) * Shape.Height > PageHeight) Then
          Shape.Width = PageHeight / Shape.Height * PageWidth
          Shape.Height = PageHeight
        Else
          Shape.Width = PageWidth
          Shape.Height = (PageWidth / Shape.Width) * Shape.Height
        End If
      ElseIf (Shape.Height > PageHeight) Then
        Shape.Width = PageHeight / Shape.Height * Shape.Width
        Shape.Height = PageHeight
      End If

      Shape.LockAspectRatio = msoTrue
    End If
  Next i
End Sub

' Helper function to insert an image into a document.
Private Sub InsertImage(FileName, Document)
  ' Ensure the target document is active.
  Document.Activate

  ' Insert the source image into the target document as an inline shape.
  Set Shape = Document.Range.InlineShapes.AddPicture(FileName, LinkToFile:=False, SaveWithDocument:=True)
End Sub

' Merge multiple PDF documents into a single PDF.
Private Sub MergePdfDocuments(PdfPath)
  'Set AcrobatApp = CreateObject("AcroExch.App")

  Set DestinationPdf = CreateObject("AcroExch.PDDoc")
  Set SourcePdf = CreateObject("AcroExch.PDDoc")

  ' Initialise the progress bar component.
  ' This resets the progress bar after converting documents to PDF.
  ProgressBox.Increment 0, "Merging..."
  Counter = 0

  ' We will merge PDFs into the first PDF.
  DestinationPdfPath = FilesToMerge.Item(1)
  DestinationPdf.Open DestinationPdfPath
  FilesToMerge.Remove (1)

  ' Iterate through the emails and attachments that were saved to the file system.
  For Each FileToMerge In FilesToMerge
    ProgressBox.Increment (Counter / FilesToMerge.Count) * 100, "Merging..."
    Sleep 250

    ' Open the source PDF.
    SourcePdf.Open FileToMerge

    ' The page number within the destination PDF where content will be inserted.
    LastPage = DestinationPdf.GetNumPages - 1

    ' The number of pages to insert.
    NumberOfPagesToInsert = SourcePdf.GetNumPages

    ' Insert the content into the destination PDF.
    DestinationPdf.InsertPages LastPage, SourcePdf, 0, NumberOfPagesToInsert, False

    ' Close and then delete the source PDF.
    SourcePdf.Close
    Kill FileToMerge

    Counter = Counter + 1
  Next FileToMerge

  ' Save the merged PDF and delete the original.
  DestinationPdf.Save 1, PdfPath
  Kill DestinationPdfPath

  ' Close the PDF document.
  DestinationPdf.Close
End Sub

This next block of code is for the user form named Progress. Note: This code, with only minor modification, was copied from the following article, and was originally written by Zack Barresse.

Private Const DefaultTitle = "Progress"
Private CurrentText As String
Private CurrentPercent As Single

Public Property Let Text(NewText As String)
  If NewText <> CurrentText Then
    CurrentText = NewText
    Me.Controls("UserText").Caption = CurrentText
    Call SizeToFit
  End If
End Property

Public Property Get Text() As String
  Text = CurrentText
End Property

Public Property Let Percent(NewPercent As Single)
  If NewPercent <> CurrentPercent Then
    CurrentPercent = Min(Max(NewPercent, 0#), 100#)
    Call UpdateProgress
  End If
End Property

Public Property Get Percent() As Single
  Percent = CurrentPercent
End Property

Public Sub Increment(ByVal NewPercent As Single, Optional ByVal NewText As String)
  Me.Percent = NewPercent
  If NewText <> "" Then Me.Text = NewText
  Call UpdateTitle
  Me.Repaint
End Sub

Private Sub UserForm_Initialize()
  Call SetupControls
  Call UpdateTitle
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  If CloseMode = vbFormControlMenu Then End 'Cancel = True
End Sub

Private Sub SetupControls()
  Dim i As Integer
  Dim Control As Object

  For i = Me.Controls.Count To 1 Step -1
    Me.Controls(i).Remove
  Next i

  Set Control = Me.Controls.Add("Forms.Label.1", "UserText", True)
  Control.Caption = ""
  Control.AutoSize = True
  Control.WordWrap = True
  Control.Font.Size = 8

  Set Control = Me.Controls.Add("Forms.Label.1", "ProgressFrame", True)
  Control.Caption = ""
  Control.Height = 16
  Control.SpecialEffect = fmSpecialEffectSunken

  Set Control = Me.Controls.Add("Forms.Label.1", "ProgressBar", True)
  Control.Caption = ""
  Control.Height = 14
  Control.BackStyle = fmBackStyleOpaque
  Control.BackColor = &HFF0000 ' Blue

  Call SizeToFit
End Sub

Private Sub SizeToFit()
  Me.Width = 240

  Me.Controls("UserText").Top = 6
  Me.Controls("UserText").Left = 6
  Me.Controls("UserText").AutoSize = False
  Me.Controls("UserText").Font.Size = 8
  Me.Controls("UserText").Width = Me.InsideWidth - 12
  Me.Controls("UserText").AutoSize = True

  Me.Controls("ProgressFrame").Top = Int(Me.Controls("UserText").Top + Me.Controls("UserText").Height) + 6
  Me.Controls("ProgressFrame").Left = 6
  Me.Controls("ProgressFrame").Width = Me.InsideWidth - 12
  Me.Controls("ProgressBar").Top = Me.Controls("ProgressFrame").Top + 1
  Me.Controls("ProgressBar").Left = Me.Controls("ProgressFrame").Left + 1

  Call UpdateProgress
  Me.Height = Me.Controls("ProgressFrame").Top + Me.Controls("ProgressFrame").Height + 6 + (Me.Height - Me.InsideHeight)
End Sub

Private Sub UpdateTitle()
  Me.Caption = DefaultTitle & " - " & Format(Int(CurrentPercent), "0") & "% Complete"
End Sub

Private Sub UpdateProgress()
  If CurrentPercent = 0 Then
    Me.Controls("ProgressBar").Visible = False
  Else
    Me.Controls("ProgressBar").Visible = True
    Me.Controls("ProgressBar").Width = Int((Me.Controls("ProgressFrame").Width - 2) * CurrentPercent / 100)
  End If
End Sub

Function Min(number1 As Single, number2 As Single) As Single
  If number1 < number2 Then Min = number1 Else Min = number2
End Function

Function Max(number1 As Single, number2 As Single) As Single
  If number1 > number2 Then Max = number1 Else Max = number2
End Function

After recreating the macro in Outlook, I recommend you create a suitably named button in the ribbon that can be used to run the ExportToPdf method.

To run the macro:

  1. Navigate to a mailbox folder that contains the emails you would like to export.
  2. Select every email you wish to export. The emails will be saved to a PDF document in the order in which they are selected. i.e. If you want the emails to be sorted in reverse chronological order, sort the folder so that the newest emails are at the top, and then select from top to bottom.
  3. Once the required emails are selected, click the "Export as PDF" button in the ribbon.
  4. A dialog will be displayed asking you to provide the name (and path) to the location where the generated PDF document will be created. Browse to a suitable location and enter a suitable name, then click Save.

    Save As Dialog
  5. The macro will commence exporting and merging the selected emails and their attachments. A status dialog will appear to give an indication of progress. There are three stages to the process; an export phase, a conversion phase, and a merge phase. The progress of all stages will be displayed. When the third stage has finished, the dialog will say 100% Complete, and then close one second later.

    Progress Dialog