Maybe try this:
Sub MergeEmailsAndAttachmentsToPDF()
' Configuration (Customize these)
Dim sharedFolderPath As String
sharedFolderPath = "\\your\shared\folder\path\"
' Replace with your shared folder path
Dim pdfFileName As String
pdfFileName = "MergedEmail.pdf"
' You can make this dynamic if needed
Dim outlookApp As Object, outlookMail As Object
Dim fso As Object, pdfFilePath As String
Dim i As Long, attachment As Object
Dim wordApp As Object, wordDoc As Object
Dim tempFilePath As String
' Create necessary objects
Set outlookApp = Application
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = False
' Keep Word hidden
' Get the selected email (you can adapt this to loop through multiple emails)
If outlookApp.Selection.Count = 0 Then
MsgBox "No email selected.", vbExclamation
Exit Sub
End If
Set outlookMail = outlookApp.Selection(1)
' Create a temporary Word document
tempFilePath = Environ("TEMP") & "\temp_email.docx"
' Use a temporary file
Set wordDoc = wordApp.Documents.Add
wordDoc.SaveAs2 tempFilePath, 16
' Save as .docx
' Add email body to Word document
With wordDoc.Content
.InsertAfter outlookMail.Subject & vbCrLf & vbCrLf
' Add subject
.InsertAfter "From: " & outlookMail.SenderEmailAddress & vbCrLf
.InsertAfter "Sent: " & outlookMail.SentOn & vbCrLf & vbCrLf
.InsertAfter outlookMail.Body & vbCrLf & vbCrLf
' Add body .InsertBreak wdPageBreak
' Page break for attachments section
.InsertAfter "Attachments:" & vbCrLf & vbCrLf
End With
' Add attachments to Word document
For Each attachment In outlookMail.Attachments
attachment.SaveAsFile Environ("TEMP") & "\" & attachment.FileName
' Save attachment temporarily
wordDoc.Content.InsertAfter attachment.FileName & vbCrLf
' List attachment names
Next attachment
' Convert Word document to PDF
pdfFilePath = sharedFolderPath & pdfFileName
wordDoc.ExportAsFixedFormat pdfFilePath, wdExportFormatPDF
' Convert to PDF
' Clean up temporary files (Word doc and attachments)
wordDoc.Close
wdSaveOptions.wdDoNotSaveChanges
fso.DeleteFile tempFilePath, True
' Delete the temporary Word file
For Each attachment In outlookMail.Attachments
fso.DeleteFile Environ("TEMP") & "\" & attachment.FileName, True
' Delete temporary attachments
Next attachment
' Close Word application
wordApp.Quit
' Release objects (important for memory management)
Set outlookMail = Nothing
Set outlookApp = Nothing
Set fso = Nothing
Set wordDoc = Nothing
Set wordApp = Nothing
Set attachment = Nothing
MsgBox "Email and attachments merged to PDF and saved to: " & pdfFilePath, vbInformation
End Sub