Outlook VBA code to convert attachments to pdf and save in a folder (1 Viewer)

aman

Registered User.
Local time
Today, 07:49
Joined
Oct 16, 2008
Messages
1,250
Hi Guys

I am looking for outlook VBA code so that when the user selects the emails in his folder and run the macro then it should check all the attachments in the email. The below things macro should do:

1. If its word document then convert that to PDF and save it down in a shared folder.
2. If the attachment is PDF already then save it down in the same format in a shared folder.

Is this achievable?

Thanks
 

June7

AWF VIP
Local time
Today, 06:49
Joined
Mar 9, 2014
Messages
5,425
Example code that saves attachments from selected emails. Converting Word document to PDF probably requires opening the document in Word and executing SaveAs. This means VBA code setting and manipulating Word objects.
Code:
Sub SaveEmailAttachment()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
'Dim strFile As String
Dim strFolderpath As String
'Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Set the Attachment folder.
strFolderpath = strFolderpath & "\Attachments\"
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection
    ' This code only strips attachments from mail items.
    ' If objMsg.class=olMail Then
    ' Get the Attachments collection of the item.
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then
        ' We need to use a count down loop for removing items
        ' from a collection. Otherwise, the loop counter gets
        ' confused and only every other item is removed.
        For i = lngCount To 1 Step -1
            objAttachments.Item(i).SaveAsFile strFolderpath & objAttachments.Item(i).FileName
        Next i
    End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
 
Last edited:

aman

Registered User.
Local time
Today, 07:49
Joined
Oct 16, 2008
Messages
1,250
Thanks June. Which email folder will it look for ? I am thinking of something like selecting the emails in an email folder and then run macro so it will look for just attachments in those emails only and not the all the emails .

How can this be done?
 

June7

AWF VIP
Local time
Today, 06:49
Joined
Mar 9, 2014
Messages
5,425
It looks in whatever folder has the focus. Select desired emails. Can use ctl+click to select discontinuous emails.

Might have read my previous post before I did some edits.
 

aman

Registered User.
Local time
Today, 07:49
Joined
Oct 16, 2008
Messages
1,250
I tried to run code but it didn't convert word document to pdf. It just saved down word document in a folder. I want to save it down in pdf format in a folder.

Thanks for your help so far.
 

June7

AWF VIP
Local time
Today, 06:49
Joined
Mar 9, 2014
Messages
5,425
No, I don't have code for the conversion. As noted in my earlier post, that will require more code. This Outlook code I already had on hand. I don't have code for converting Word doc.
 

June7

AWF VIP
Local time
Today, 06:49
Joined
Mar 9, 2014
Messages
5,425
Be aware that images in the email, such as might be found in a signature block might save out same as attachment. That's what happens to me.

Here is a procedure that does the conversion, adapted from the link I referenced.

Code:
Sub WordToPDF(strWord As String)
Dim oW As Word.Application
Dim oD As Word.Document
Set oW = CreateObject("Word.Application")
Set oD = oW.Documents.Open(strWord)
oD.ExportAsFixedFormat Left(strWord, InStrRev(strWord, ".")) & "pdf", wdExportFormatPDF, False, wdExportOptimizeForPrint
oD.Close False
Kill (strWord)
End Sub
Call the procedure:
Code:
            objAttachments.Item(i).SaveAsFile strFolderpath & objAttachments.Item(i).FileName
            If objAttachments.Item(i).FileName Like "*.doc*" Then
                WordToPDF (strFolderpath & objAttachments.Item(i).FileName)
            End If
 
Last edited:

aman

Registered User.
Local time
Today, 07:49
Joined
Oct 16, 2008
Messages
1,250
June, The following code will combine email body and attachment in any format into one pdf file. It works really good. But I am not able to select multiple emails , this code works only if we select one email.
Code:
Public Sub MergeMailAndAttachsToPDF()
'Update by Extendoffice 2018/3/5
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
 
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
xPDFSavePath = xExcel.Application.GetSaveAsFilename(InitialFileName:="", FileFilter:="PDF Files(*.pdf),*.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 = xPath & 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(xPath)
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
 

aman

Registered User.
Local time
Today, 07:49
Joined
Oct 16, 2008
Messages
1,250
Hi Guys

Can anyone please help me with this? My above code works fine if I select one email in a folder but doesn't work for multiple emails selection. How can I save email body and attachments in a separate pdf file for each email?

Thanks
 

Gasman

Enthusiastic Amateur
Local time
Today, 14:49
Joined
Sep 21, 2011
Messages
14,054
Loop through each email and call your code. ?
Combine June7's code with your own.

Hint
Code:
For Each objMsg In objSelection
 

June7

AWF VIP
Local time
Today, 06:49
Joined
Mar 9, 2014
Messages
5,425
Probably also want to add conditional code that only grabs attachments with filename ending in ".doc*" or ".pdf".
 

aman

Registered User.
Local time
Today, 07:49
Joined
Oct 16, 2008
Messages
1,250
Can you please help me to combine 'Loop through each email' code with the code I sent?

Many Thanks
 

Gasman

Enthusiastic Amateur
Local time
Today, 14:49
Joined
Sep 21, 2011
Messages
14,054
Well bearing in mind my signature, and I cannot really test this, try
Ideally I think it would be cleaner to call your your code completely from another sub which walked through the selected emails, but we'll try the simple way first.

I've only amended the first sub, as I believe that is all that needs changing.?

Code:
Public Sub MergeMailAndAttachsToPDF()
'Update by Extendoffice 2018/3/5
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 objOL as object, objSelection As Outlook.Selection
 
On Error Resume Next
If Outlook.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "Please Select a email.", vbInformation + vbOKOnly
    Exit Sub
End If

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Now loop through all selected emails
For Each xMail In objSelection
'    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
    xPDFSavePath = xExcel.Application.GetSaveAsFilename(InitialFileName:="", FileFilter:="PDF Files(*.pdf),*.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 = xPath & 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(xPath)
    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

Next
Set xMail = Nothing
Set objSelection = Nothing
Set xNameSpace = Nothing
Set xFSysObj = Nothing
MsgBox "Merged successfully", vbInformation + vbOKOnly
End Sub

HTH
 
Last edited:

Gasman

Enthusiastic Amateur
Local time
Today, 14:49
Joined
Sep 21, 2011
Messages
14,054
Or this?
Code:
Sub SaveAttachments()
Dim objOL as Object, objSelection as Outlook.Selection
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Now call the attachment code
Call MergeMailAndAttachsToPDF(objSelection)
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Public Sub MergeMailAndAttachsToPDF(pobjSelection as Outlook.Selection)
'Update by Extendoffice 2018/3/5
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 objOL as object, objSelection As Outlook.Selection
 
On Error Resume Next
If Outlook.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "Please Select a email.", vbInformation + vbOKOnly
    Exit Sub
End If

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = pobjSelection

' Now loop through all selected emails
For Each xMail In objSelection
'    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
    xPDFSavePath = xExcel.Application.GetSaveAsFilename(InitialFileName:="", FileFilter:="PDF Files(*.pdf),*.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 = xPath & 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(xPath)
    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

Next
Set xMail = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set xNameSpace = Nothing
Set xFSysObj = Nothing
MsgBox "Merged successfully", vbInformation + vbOKOnly
End Sub
 

June7

AWF VIP
Local time
Today, 06:49
Joined
Mar 9, 2014
Messages
5,425
Consider:

If xExt LIKE ".doc*" Or xExt LIKE ".dot*"

Not seeing .pdf in the conditional for attachment file extension. Did OP say some attachments could already be pdf file?
 

Gasman

Enthusiastic Amateur
Local time
Today, 14:49
Joined
Sep 21, 2011
Messages
14,054
Not sure June7.
I was only concentrating on combining what the OP said worked, with your logic.

I use something similar in my Outlook, but save everything as is, and that was a lot of change this, change that. :D

Consider:

If xExt LIKE ".doc*" Or xExt LIKE ".dot*"

Not seeing .pdf in the conditional for attachment file extension. Did OP say some attachments could already be pdf file?
 

aman

Registered User.
Local time
Today, 07:49
Joined
Oct 16, 2008
Messages
1,250
Thanks Gasman , It worked but everytime it creates PDF file , a dialog window opens up and ask for a name . Can we automate it so that it saves PDF file with the name as below

'The person who sent an email' & 'Date when the email was sent'
 

aman

Registered User.
Local time
Today, 07:49
Joined
Oct 16, 2008
Messages
1,250
AUtomatically each PDF file should be saved down in folder :

U:\ABC\Outlook
 

Users who are viewing this thread

Top Bottom