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