Consulting

Results 1 to 3 of 3

Thread: Merge email message and attachements into one pdf file

  1. #1

    Merge email message and attachements into one pdf file

    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

  2. #2
    Can anyone please help me in this? Thanks

  3. #3

    hi. Have you managed to fix thee code?

    Quote Originally Posted by RajOberoi View Post
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •