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

[Gasman]

What did it do when you could only work one one email.?

 

[aman]

Also the code is not considering "pdf" files which needs to be saved down as well.

 

[aman]

Even that time it was showing dialog box to choose folder where pdf file needs to be saved.
I changed the line of code as below so that it points to the right folder but I want the files to be saved down automatically and as i said earlier the files names should be picked up automatically (the person who send an email/Date etc..)

Set xWdApp = New Word.Application
    xExcel.DisplayAlerts = False
    xPDFSavePath = xExcel.Application.GetSaveAsFilename(InitialFileName:="U:\ABC\Oulook\Word\", FileFilter:="PDF Files(*.pdf),*.pdf")
    If xPDFSavePath = "False" Then
        xExcel.DisplayAlerts = True
        xExcel.Quit
        xWdApp.Quit
        Exit Sub
    End If

What did it do when you could only work one one email.?

 

[Gasman]

As you are using SaveAs2

https://docs.microsoft.com/en-us/office/vba/api/word.saveas2

Insert your filename convention in the correct place, or use the keywords.

 

[Gasman]

Also the code is not considering "pdf" files which needs to be saved down as well.

Come one, work with me here. :banghead:

You are not going to learn anything if everyone writes the code for you.

I'm all for googling how to do something or something similiar, and amend to suit, but at the same time learn how it does what it does.

 

[aman]

I changed the code to below but its still asking me to click save in dialog window:

Set xWdApp = New Word.Application
    xExcel.DisplayAlerts = False
    xPDFSavePath = xExcel.Application.GetSaveAsFilename(InitialFileName:="U:\ABC\Outlook\Word\" & Environ("username") & " " & Date, FileFilter:="PDF Files(*.pdf),*.pdf")
    If xPDFSavePath = "False" Then
        xExcel.DisplayAlerts = True
        xExcel.Quit
        xWdApp.Quit
        Exit Sub
    End If

 

[Gasman]

Are you even sure it is at that line?, as you save files in various places.
Walk through the code with one email selected using F8 in the debug window.
That is what I always do when code does not behave as I expected it to (and that happens often)

I would have thought it would be here, if anywhere

xNewDoc.SaveAs2 xPDFSavePath, wdFormatPDF

 

[Minty]

PMFJI - But shouldn't you need to issue a

.Save

somewhere in there?

 

[aman]

Guys, The only thing left is saving down all the files automatically without opening the dialog window. I hope anyone out there can help me with this. Below is the code we got so far:

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:="U:\ABC\Outlook\Word\", 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 = CleanFileName1(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 = SplitPath1(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") Or (xExt = ".pdf") Then
            atmtName = CleanFileName1(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() = GetFiles1(xPath)
    For I = 0 To UBound(xFileArr()) - 1
        xExt = SplitPath1(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() = GetFiles1(xPath)
    'Merge Documents
    For I = 0 To UBound(xFileArr()) - 1
        xExt = SplitPath1(xFileArr(I), 2)
        If (xExt = ".docx") Or (xExt = ".doc") Or (xExt = ".docm") Or (xExt = ".dot") Or _
           (xExt = ".dotm") Or (xExt = ".dotx") Then
            MergeDoc1 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
Public Function SplitPath1(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
   SplitPath1 = Left(FullPath, SplitPos - 1)
Case 1
   If DotPos = 0 Then DotPos = Len(FullPath) + 1
   SplitPath1 = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
   If DotPos = 0 Then DotPos = Len(FullPath)
   SplitPath1 = Mid(FullPath, DotPos)
Case Else
   Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function
Function CleanFileName1(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
CleanFileName1 = StrText
End Function
Function GetFiles1(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
GetFiles1 = xArr()
End Function
 
Sub MergeDoc1(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

 

[Gasman]

You need to review my previous post.
What is the value of xPDFSavePath in the Word section of the code?
Again, walk through the code with breakpoints set to see where you actually get the dialogue

 

[aman]

Sorry guys, I am back again. How can we put a control so that any invisible attachments (logos,signatures etc..) will not be saved down on the network. Basically VBA code that will distinguish between real and fake attachments.

Many thanks.

 

[June7]

I see you have started another thread with this new question https://access-programmers.co.uk/forums/showthread.php?t=302556