Merge email message and attachements into one pdf file

**RajOberoi** · 02-26-2019, 05:54 AM

Hi guys,

I got the following code which merges email messages and the attachments into one pdf file of the selected email and save it down on the shared folder. I want to do the folloiwng things :

1. At the moment when it merges email message and attachments into pdf then in the pdf file attachments appear first and then at the bottom email message appear . I want it done the other way so email message on the top and then attacments at the bottom.

2. The code ignores any pdf attachments or JPEG attachments in the email .

3. My clients won't receive any excel attachments so I want to tidy up the code so it won't look for excel attachments.

Public Sub MergeMailAndAttachsToPDF_New(MortANo As String)
Dim xSelMails As MailItem
Dim xFSysObj As FileSystemObject
Dim xOverwriteBln As Boolean
Dim xLooper As Integer
Dim xEntryID As String
Dim xNameSpace As Outlook.NameSpace
Dim xMail As Outlook.MailItem
Dim xExt As String
Dim xSendEmailAddr, xCompanyDomain As String
Dim xWdApp As Word.Application
Dim xDoc, xNewDoc As Word.Document
Dim I As Integer
Dim xPDFSavePath As String
Dim xPath As String
Dim xFileArr() As String
'Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim xTempDoc As Word.Document
Dim strFileName As String

On Error Resume Next
If (Outlook.ActiveExplorer.Selection.Count > 1) Or (Outlook.ActiveExplorer.Selection.Count = 0) Then
    MsgBox "Please Select a email.", vbInformation + vbOKOnly
    Exit Sub
End If
Set xSelMails = Outlook.ActiveExplorer.Selection.Item(1)
xEntryID = xSelMails.EntryID
Set xNameSpace = Application.GetNamespace("MAPI")
Set xMail = xNameSpace.GetItemFromID(xEntryID)
 
xSendEmailAddr = xMail.SenderEmailAddress
xCompanyDomain = Right(xSendEmailAddr, Len(xSendEmailAddr) - InStr(xSendEmailAddr, "@"))
xOverwriteBln = False
Set xExcel = New Excel.Application
xExcel.Visible = False
Set xWdApp = New Word.Application
xExcel.DisplayAlerts = False
strSaveFldr = GetPrivateProfileString32("U:\test.ini", "SaveFolder", "FolderName")
strFileName = MortANo & "-" & DocType_Col1 & "-" & email & "-" & Environ("Username")
xPDFSavePath = strSaveFldr & strFileName & ".pdf"
If xPDFSavePath = "False" Then
   xExcel.DisplayAlerts = True
   xExcel.Quit
   xWdApp.Quit
   Exit Sub
End If
xPath = Left(xPDFSavePath, InStrRev(xPDFSavePath, ""))
cPath = xPath & xCompanyDomain & ""
yPath = cPath & Format(Now(), "yyyy") & ""
mPath = yPath & Format(Now(), "MMMM") & ""
If Dir(xPath, vbDirectory) = vbNullString Then
   MkDir xPath
End If
EmailSubject = CleanFileName(xMail.Subject)
xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & ".doc"
Set xFSysObj = CreateObject("Scripting.FileSystemObject")
If xOverwriteBln = False Then
   xLooper = 0
  Do While xFSysObj.FileExists(yPath & xSaveName)
      xLooper = xLooper + 1
      xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & "_" & xLooper & ".doc"
   Loop
Else
   If xFSysObj.FileExists(yPath & xSaveName) Then
      xFSysObj.DeleteFile yPath & xSaveName
   End If
End If
xMail.SaveAs xPath & xSaveName, olDoc
If xMail.Attachments.Count > 0 Then
   For Each Atmt In xMail.Attachments
      xExt = SplitPath(Atmt.FileName, 2)
      If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or (xExt = ".dotm") Or (xExt = ".dotx") _
      Or (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or (xExt = ".xltm") Or (xExt = ".xltx") Then
        atmtName = CleanFileName(Atmt.FileName)
        atmtSave = strSaveFldr & Format(xMail.ReceivedTime, "yyyymmdd") & "_" & atmtName
        Atmt.SaveAsFile atmtSave
      End If
   Next
End If
Set xNewDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
Set xFilesFld = xFSysObj.GetFolder(xPath)
xFileArr() = GetFiles(strSaveFldr)
For I = 0 To UBound(xFileArr()) - 1
    xExt = SplitPath(xFileArr(I), 2)
    If (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or _
       (xExt = ".xltm") Or (xExt = ".xltx") Then  'conver excel to word
        Set xWb = xExcel.Workbooks.Open(xPath & xFileArr(I))
        Set xTempDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
        Set xWs = xWb.ActiveSheet
        xWs.UsedRange.Copy
        xTempDoc.Content.PasteAndFormat wdFormatOriginalFormatting
        xTempDoc.SaveAs2 xPath & xWs.Name + ".docx", wdFormatXMLDocument
        xWb.Close False
        Kill xPath & xFileArr(I)
        xTempDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
    End If
Next
xExcel.DisplayAlerts = True
xExcel.Quit
xFileArr() = GetFiles(xPath)
'Merge Documents
For I = 0 To UBound(xFileArr()) - 1
    xExt = SplitPath(xFileArr(I), 2)
    If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or _
       (xExt = ".dotm") Or (xExt = ".dotx") Then
        MergeDoc xWdApp, xPath & xFileArr(I), xNewDoc
        Kill xPath & xFileArr(I)
    End If
Next
xNewDoc.Sections.Item(1).Range.Delete wdCharacter, 1
xNewDoc.SaveAs2 xPDFSavePath, wdFormatPDF
xNewDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
xWdApp.Quit
Set xMail = Nothing
Set xNameSpace = Nothing
Set xFSysObj = Nothing
MsgBox "Merged successfully", vbInformation + vbOKOnly
End Sub
 
Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "/")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
   SplitPath = Left(FullPath, SplitPos - 1)
Case 1
   If DotPos = 0 Then DotPos = Len(FullPath) + 1
   SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
   If DotPos = 0 Then DotPos = Len(FullPath)
   SplitPath = Mid(FullPath, DotPos)
Case Else
   Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function
   
Function CleanFileName(StrText As String) As String
Dim xStripChars As String
Dim xLen As Integer
Dim I As Integer
xStripChars = "/\[]:=," & Chr(34)
xLen = Len(xStripChars)
StrText = Trim(StrText)
For I = 1 To xLen
StrText = Replace(StrText, Mid(xStripChars, I, 1), "")
Next
CleanFileName = StrText
End Function
 
Function GetFiles(xFldPath As String) As String()
On Error Resume Next
Dim xFile As String
Dim xFileArr() As String
Dim xArr() As String
Dim I, x As Integer
x = 0
ReDim xFileArr(1)
xFileArr(1) = xFldPath '& ""
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
    x = x + 1
    xFile = Dir
Loop
ReDim xArr(0 To x)
x = 0
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
    xArr(x) = xFile
    x = x + 1
    xFile = Dir
Loop
GetFiles = xArr()
End Function
 
Sub MergeDoc(WdApp As Word.Application, xFileName As String, Doc As Document)
Dim xNewDoc As Document
Dim xSec As Section
    Set xNewDoc = WdApp.Documents.Open(FileName:=xFileName, Visible:=False)
    Set xSec = Doc.Sections.Add
    xNewDoc.Content.Copy
    xSec.PageSetup = xNewDoc.PageSetup
    xSec.Range.PasteAndFormat wdFormatOriginalFormatting
    xNewDoc.Close
End Sub

Any help will be much appreciated . Thanks

**RajOberoi** · 02-27-2019, 01:40 AM

Can anyone please help me in this? Thanks

**NewED** · 03-10-2020, 05:40 AM

Originally Posted by RajOberoi

Hi guys,

I got the following code which merges email messages and the attachments into one pdf file of the selected email and save it down on the shared folder. I want to do the folloiwng things :

1. At the moment when it merges email message and attachments into pdf then in the pdf file attachments appear first and then at the bottom email message appear . I want it done the other way so email message on the top and then attacments at the bottom.

2. The code ignores any pdf attachments or JPEG attachments in the email .

3. My clients won't receive any excel attachments so I want to tidy up the code so it won't look for excel attachments.

Public Sub MergeMailAndAttachsToPDF_New(MortANo As String)
Dim xSelMails As MailItem
Dim xFSysObj As FileSystemObject
Dim xOverwriteBln As Boolean
Dim xLooper As Integer
Dim xEntryID As String
Dim xNameSpace As Outlook.NameSpace
Dim xMail As Outlook.MailItem
Dim xExt As String
Dim xSendEmailAddr, xCompanyDomain As String
Dim xWdApp As Word.Application
Dim xDoc, xNewDoc As Word.Document
Dim I As Integer
Dim xPDFSavePath As String
Dim xPath As String
Dim xFileArr() As String
'Dim xExcel As Excel.Application
Dim xWb As Workbook
Dim xWs As Worksheet
Dim xTempDoc As Word.Document
Dim strFileName As String

On Error Resume Next
If (Outlook.ActiveExplorer.Selection.Count > 1) Or (Outlook.ActiveExplorer.Selection.Count = 0) Then
    MsgBox "Please Select a email.", vbInformation + vbOKOnly
    Exit Sub
End If
Set xSelMails = Outlook.ActiveExplorer.Selection.Item(1)
xEntryID = xSelMails.EntryID
Set xNameSpace = Application.GetNamespace("MAPI")
Set xMail = xNameSpace.GetItemFromID(xEntryID)
 
xSendEmailAddr = xMail.SenderEmailAddress
xCompanyDomain = Right(xSendEmailAddr, Len(xSendEmailAddr) - InStr(xSendEmailAddr, "@"))
xOverwriteBln = False
Set xExcel = New Excel.Application
xExcel.Visible = False
Set xWdApp = New Word.Application
xExcel.DisplayAlerts = False
strSaveFldr = GetPrivateProfileString32("U:\test.ini", "SaveFolder", "FolderName")
strFileName = MortANo & "-" & DocType_Col1 & "-" & email & "-" & Environ("Username")
xPDFSavePath = strSaveFldr & strFileName & ".pdf"
If xPDFSavePath = "False" Then
   xExcel.DisplayAlerts = True
   xExcel.Quit
   xWdApp.Quit
   Exit Sub
End If
xPath = Left(xPDFSavePath, InStrRev(xPDFSavePath, ""))
cPath = xPath & xCompanyDomain & ""
yPath = cPath & Format(Now(), "yyyy") & ""
mPath = yPath & Format(Now(), "MMMM") & ""
If Dir(xPath, vbDirectory) = vbNullString Then
   MkDir xPath
End If
EmailSubject = CleanFileName(xMail.Subject)
xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & ".doc"
Set xFSysObj = CreateObject("Scripting.FileSystemObject")
If xOverwriteBln = False Then
   xLooper = 0
  Do While xFSysObj.FileExists(yPath & xSaveName)
      xLooper = xLooper + 1
      xSaveName = Format(xMail.ReceivedTime, "yyyymmdd") & "_" & EmailSubject & "_" & xLooper & ".doc"
   Loop
Else
   If xFSysObj.FileExists(yPath & xSaveName) Then
      xFSysObj.DeleteFile yPath & xSaveName
   End If
End If
xMail.SaveAs xPath & xSaveName, olDoc
If xMail.Attachments.Count > 0 Then
   For Each Atmt In xMail.Attachments
      xExt = SplitPath(Atmt.FileName, 2)
      If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or (xExt = ".dotm") Or (xExt = ".dotx") _
      Or (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or (xExt = ".xltm") Or (xExt = ".xltx") Then
        atmtName = CleanFileName(Atmt.FileName)
        atmtSave = strSaveFldr & Format(xMail.ReceivedTime, "yyyymmdd") & "_" & atmtName
        Atmt.SaveAsFile atmtSave
      End If
   Next
End If
Set xNewDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
Set xFilesFld = xFSysObj.GetFolder(xPath)
xFileArr() = GetFiles(strSaveFldr)
For I = 0 To UBound(xFileArr()) - 1
    xExt = SplitPath(xFileArr(I), 2)
    If (xExt = ".xlsx") Or (xExt = ".xls") Or (xExt = ".xlsm") Or (xExt = ".xlt") Or _
       (xExt = ".xltm") Or (xExt = ".xltx") Then  'conver excel to word
        Set xWb = xExcel.Workbooks.Open(xPath & xFileArr(I))
        Set xTempDoc = xWdApp.Documents.Add("Normal", False, wdNewBlankDocument, False)
        Set xWs = xWb.ActiveSheet
        xWs.UsedRange.Copy
        xTempDoc.Content.PasteAndFormat wdFormatOriginalFormatting
        xTempDoc.SaveAs2 xPath & xWs.Name + ".docx", wdFormatXMLDocument
        xWb.Close False
        Kill xPath & xFileArr(I)
        xTempDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
    End If
Next
xExcel.DisplayAlerts = True
xExcel.Quit
xFileArr() = GetFiles(xPath)
'Merge Documents
For I = 0 To UBound(xFileArr()) - 1
    xExt = SplitPath(xFileArr(I), 2)
    If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or _
       (xExt = ".dotm") Or (xExt = ".dotx") Then
        MergeDoc xWdApp, xPath & xFileArr(I), xNewDoc
        Kill xPath & xFileArr(I)
    End If
Next
xNewDoc.Sections.Item(1).Range.Delete wdCharacter, 1
xNewDoc.SaveAs2 xPDFSavePath, wdFormatPDF
xNewDoc.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, False
xWdApp.Quit
Set xMail = Nothing
Set xNameSpace = Nothing
Set xFSysObj = Nothing
MsgBox "Merged successfully", vbInformation + vbOKOnly
End Sub
 
Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "/")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
   SplitPath = Left(FullPath, SplitPos - 1)
Case 1
   If DotPos = 0 Then DotPos = Len(FullPath) + 1
   SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
   If DotPos = 0 Then DotPos = Len(FullPath)
   SplitPath = Mid(FullPath, DotPos)
Case Else
   Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function
   
Function CleanFileName(StrText As String) As String
Dim xStripChars As String
Dim xLen As Integer
Dim I As Integer
xStripChars = "/\[]:=," & Chr(34)
xLen = Len(xStripChars)
StrText = Trim(StrText)
For I = 1 To xLen
StrText = Replace(StrText, Mid(xStripChars, I, 1), "")
Next
CleanFileName = StrText
End Function
 
Function GetFiles(xFldPath As String) As String()
On Error Resume Next
Dim xFile As String
Dim xFileArr() As String
Dim xArr() As String
Dim I, x As Integer
x = 0
ReDim xFileArr(1)
xFileArr(1) = xFldPath '& ""
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
    x = x + 1
    xFile = Dir
Loop
ReDim xArr(0 To x)
x = 0
xFile = Dir(xFileArr(1) & "*.*")
Do Until xFile = ""
    xArr(x) = xFile
    x = x + 1
    xFile = Dir
Loop
GetFiles = xArr()
End Function
 
Sub MergeDoc(WdApp As Word.Application, xFileName As String, Doc As Document)
Dim xNewDoc As Document
Dim xSec As Section
    Set xNewDoc = WdApp.Documents.Open(FileName:=xFileName, Visible:=False)
    Set xSec = Doc.Sections.Add
    xNewDoc.Content.Copy
    xSec.PageSetup = xNewDoc.PageSetup
    xSec.Range.PasteAndFormat wdFormatOriginalFormatting
    xNewDoc.Close
End Sub

Any help will be much appreciated . Thanks

**Aussiebear** · 02-02-2025, 07:58 PM

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

Thread: Merge email message and attachements into one pdf file

Thread Tools

Display

Merge email message and attachements into one pdf file

hi. Have you managed to fix thee code?

Posting Permissions