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 following 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 attachments 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