Sub SaveEmailAsPDF()
Dim outlookApp As Outlook.Application
Dim mail As Outlook.MailItem
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim pdfPath As String
Dim saveDirectory As String
' Initialize Outlook and get the selected email
Set outlookApp = Outlook.Application
Set mail = outlookApp.ActiveExplorer.Selection.Item(1)
' Define where to save the PDF
saveDirectory = "C:\Path\To\Save" ' Change to your desired path
pdfPath = saveDirectory & "\" & Replace(mail.Subject, ":", "-") & ".pdf"
' Initialize Word Application
Set wordApp = CreateObject("Word.Application")
' Create a new Word document
Set wordDoc = wordApp.Documents.Add
' Insert email metadata and body into the Word document
With wordDoc
.Content.Font.Name = "Arial"
.Content.Font.Size = 10
.Content.Text = "From: " & mail.SenderName & vbCrLf
.Content.InsertAfter "To: " & mail.To & vbCrLf
.Content.InsertAfter "CC: " & mail.CC & vbCrLf
.Content.InsertAfter "Subject: " & mail.Subject & vbCrLf
.Content.InsertAfter "Sent: " & mail.SentOn & vbCrLf & vbCrLf
.Content.InsertAfter mail.Body
End With
' Save the Word document as PDF
wordDoc.SaveAs2 pdfPath, FileFormat:=wdFormatPDF
' Close the Word document
wordDoc.Close False
wordApp.Quit
' Release the objects
Set wordDoc = Nothing
Set wordApp = Nothing
Set mail = Nothing
Set outlookApp = Nothing
End Sub
