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
