Option Explicit
'https://stackoverflow.com/questions/51655911/export-outlook-email-as-pdf
Sub OutLook_Export_2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = "Please wait, macro in progess !"
Dim MyOutlook As Outlook.Application
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim FSO As Object, TmpFolder As Object
Dim sName As String
Dim ONS As Outlook.Namespace
Dim MYFOLD As Outlook.Folder
Dim OMAIL As Object
Dim R As Long
Dim ListSht As Worksheet
Dim WshShell As Object
Dim SpecialPath As String
Dim strToSaveAs As String
Dim J As Variant
Dim TmpFileName As Variant
Dim MyDocs As Variant
Dim MapSht As Worksheet
Dim TempLr As Long
Set MapSht = ThisWorkbook.Worksheets("Mapping")
On Error Resume Next
Set wrdApp = CreateObject("Word.Application")
Set MyOutlook = New Outlook.Application
Set ONS = MyOutlook.GetNamespace("MAPI")
Set ONS = MyOutlook.PickFolder
'Set MYFOLD = ONS.GetDefaultFolder(olFolderInbox)
Set MYFOLD = ONS.PickFolder
Set OMAIL = MyOutlook.CreateItem(olMailItem)
Set ListSht = ThisWorkbook.Worksheets("List")
Dim MyCount As Long
MyCount = 0
For Each OMAIL In MYFOLD.Items
TempLr = MapSht.Cells(MapSht.Rows.Count, 3).End(xlUp).Row + 1
MapSht.Cells(TempLr, 3).Value = TempLr - 1
MapSht.Cells(TempLr, 4).Value = OMAIL.Subject
MapSht.Cells(TempLr, 5) = OMAIL.ConversationID 'E Conversation ID
MapSht.Cells(TempLr, 6) = OMAIL.ConversationTopic 'F Conversation Topic
MapSht.Cells(TempLr, 7) = OMAIL.ReceivedTime 'G Received Time
MapSht.Cells(TempLr, 8) = OMAIL.To 'H To
MapSht.Cells(TempLr, 9) = OMAIL.Sender 'I From
MapSht.Cells(TempLr, 10) = Now 'J Run time
MyCount = MyCount + 1
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TmpFileName = MapSht.Range("A2")
sName = Left(OMAIL.Subject, 60) & "_" & MyCount
ReplaceCharsForFileName sName, "-"
TmpFileName = TmpFileName & "\" & sName & ".mht"
OMAIL.SaveAs TmpFileName, olMHTML
MapSht.Cells(TempLr, 11) = TmpFileName
Set wrdDoc = wrdApp.Documents.Open(Filename:=TmpFileName, Visible:=True)
Set WshShell = CreateObject("WScript.Shell")
MyDocs = MapSht.Range("A2").Value
strToSaveAs = MyDocs & "\" & sName & ".pdf"
MapSht.Cells(TempLr, 12) = strToSaveAs
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
wrdDoc.Close
wrdApp.Quit
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set WshShell = Nothing
Next OMAIL
MyCount = 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
MsgBox "Done!"
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
