VBA: Outlook Macro for saving selected emails as PDF's.

 This VBA Macro for Outlook will take a selected emails and save it to c:\Temp folder as PDF's

'Outlook Macro for taking selected emails and exporting them to a folder as PDF's.
'Assumes you have Word installed and are an Exchange user.

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

Sub SaveSelectedMailAsPDFFile()
  Const OLTXT = 0
  Dim currentExplorer As Explorer
  Dim Selection As Selection
  Dim oMail As Outlook.MailItem
  Dim obj As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String

  Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection

  For Each obj In Selection
    Set oMail = obj
    SaveAsPDF oMail
  Next
  MsgBox "Selected Emails saved as PDF to C:\Temp folder"
End Sub

Function ResolveDisplayNameToSMTP(sFromName)
  Dim oRecip As Outlook.Recipient
  Dim oEU As Outlook.ExchangeUser
  Dim oEDL As Outlook.ExchangeDistributionList
  
  Set oRecip = Application.Session.CreateRecipient(sFromName)
  oRecip.Resolve
  If oRecip.Resolved Then
    Select Case oRecip.AddressEntry.AddressEntryUserType
      Case OlAddressEntryUserType.olExchangeUserAddressEntry
        Set oEU = oRecip.AddressEntry.GetExchangeUser
        If Not (oEU Is Nothing) Then
          ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress + vbCrLf + oEU.BusinessTelephoneNumber
        End If
      Case OlAddressEntryUserType.olOutlookContactAddressEntry
        Set oEU = oRecip.AddressEntry.GetExchangeUser
        If Not (oEU Is Nothing) Then
          ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress + vbCrLf + oEU.BusinessTelephoneNumber
        End If
      Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
        Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
        If Not (oEDL Is Nothing) Then
          ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress + vbCrLf + oEU.BusinessTelephoneNumber
        End If
    End Select
  End If
End Function  ' ResolveDisplayNameToSMTP

Sub SaveAsPDF(MyMail As MailItem)
  ' ### Requires reference to Microsoft Scripting Runtime ###
  ' ### Requires reference to Microsoft Word Object Library ###
  ' --- In VBE click TOOLS > REFERENCES and check the boxes for both of the above ---
  Dim fso As FileSystemObject
  Dim strSubject As String
  Dim sFromName As String
  Dim strSaveName As String
  Dim sSMTPAddress As String
  Dim blnOverwrite As Boolean
  Dim strFolderPath As String
  Dim sendEmailAddr As String
  Dim senderName As String
  Dim looper As Integer
  Dim plooper 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 username portion of sender email address ###
  senderName = oMail.senderName
  sendEmailAddr = ResolveDisplayNameToSMTP(senderName)  ' use internal internal Exchange domain address if available
  If sendEmailAddr = Empty Then  ' , otherwise use external smtp address
    sendEmailAddr = oMail.SenderEmailAddress
  End If

  ' ### USER OPTIONS ###
  blnOverwrite = False ' False = don't overwrite, True = do overwrite

  ' ### Path to save directory ###
  bPath = "C:\Temp\"

  ' ### Create Directory if it doesnt exist ###
  If Dir(bPath, vbDirectory) = vbNullString Then
      MkDir bPath
  End If

  ' ### Get Email subject & set name to be saved as ###
  emailSubject = CleanFileName(oMail.Subject)
  saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & emailSubject & ".mht"
  Set fso = CreateObject("Scripting.FileSystemObject")

  ' ### Increment filename if it already exists ###
  If blnOverwrite = False Then
      looper = 0
      Do While fso.FileExists(bPath & saveName)
          looper = looper + 1
          saveName = Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & "_" & looper & ".mht"
          Loop
  Else
  End If

  ' ### Save .mht file to create pdf from Word ###
  oMail.SaveAs bPath & saveName, olMHTML
  pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & ".pdf"

  If fso.FileExists(pdfSave) Then
      plooper = 0
      Do While fso.FileExists(pdfSave)
      plooper = plooper + 1
      pdfSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & senderName & "_" & emailSubject & "_" & plooper & ".pdf"
      Loop
  Else
  End If


  ' ### Open Word to convert .mht file to PDF ###
  Dim wrdApp As Word.Application
  Dim wrdDoc As Word.Document
  Set wrdApp = CreateObject("Word.Application")

  ' ### Open .mht file we just saved and export as PDF ###
  ' ActiveDocument.PrintOut PrintZoomPaperWidth:= 72 * 8.5, PrintZoomPaperHeight:= 72 * 11
  Set wrdDoc = wrdApp.Documents.Open(FileName:=bPath & saveName, Visible:=True)

  PicturesFitPageWidth wrdApp.ActiveDocument


  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

  ' ### Delete .mht file ###
  'mht file is good if tables are used, preserves the full file, so keep them both for now.
  'Kill bPath & saveName

  ' ### Uncomment this section to save attachments ###
  'If oMail.Attachments.Count > 0 Then
  '    For Each atmt In oMail.Attachments
  '        atmtName = CleanFileName(atmt.FileName)
  '        atmtSave = bPath & Format(oMail.ReceivedTime, "yyyy-mm-dd-hhmm") & "_" & atmtName
  '        atmt.SaveAsFile atmtSave
  '    Next
  'End If

  Set oMail = Nothing
  Set olNS = Nothing
  Set fso = Nothing
End Sub

Sub PicturesFitPageWidth(ActiveDocument As Variant)
  ' ResizePic Macro
  ' Resizes an image

  Shapes = ActiveDocument.Shapes.count
  InLines = ActiveDocument.InlineShapes.count
  oTables = ActiveDocument.Tables.count
  'Sets the variables to loop through all shapes in the document, one for shapes and one for inline shapes.


  'Calculate usable width of page

  With ActiveDocument.PageSetup
      WidthAvail = .PageWidth - .LeftMargin - .RightMargin
  End With

  'Loop through all shapes and lines in the document.  Checks to see if they're too wide, and if they are, resizes them.

  For ShapeLoop = 1 To Shapes
      'MsgBox Prompt:="Shape " & ShapeLoop & " width: " & ActiveDocument.Shapes(ShapeLoop).Width
      If ActiveDocument.Shapes(ShapeLoop).Width > WidthAvail Then
          ActiveDocument.Shapes(ShapeLoop).Width = WidthAvail
      End If
  Next ShapeLoop 

  For InLineLoop = 1 To InLines
      'MsgBox Prompt:="Inline " & InLineLoop & " width: " & ActiveDocument.InlineShapes(InLineLoop).Width
      If ActiveDocument.InlineShapes(InLineLoop).Width > WidthAvail Then
          ActiveDocument.InlineShapes(InLineLoop).Width = WidthAvail
      End If
  Next InLineLoop

End Sub