0

Estou tentando fazer um código para gerar um PDF para cada arquivo Excel que eu tenho em uma pasta. Primeiramente meu código gera um PDF cada arquivo excel e depois gera um PDF que seria a capa de todos esses arquivos.

O problema que estou tendo é que gera em arquivos separados, alguém tem ideia de como poderia gerar um arquivo de PDF somente?

Sub BatchOpenMultiplePSTFiles()

    Dim objShell As Object

    Dim objWindowsFolder As Object

    Dim strWindowsFolder As String

    Application.ScreenUpdating = False

    'Desliga Atualização de Tela

    Application.DisplayAlerts = False

    'Desliga Alertas

    'Select the specific Windows folder

    Caminho = ThisWorkbook.Path

    'Caminho do Arquivo

    Set objShell = CreateObject("Shell.Application")

    Set objWindowsFolder = objShell.BrowseForFolder(0, "Selecione a pasta com os arquivos" _

    & "Excel que deseja transformar em PDF:", 0, "")

    If Not objWindowsFolder Is Nothing Then

        'Se não selecionar nada, não faz nada

        strWindowsFolder = objWindowsFolder.self.Path & "\"

        Call ProcessFolders(strWindowsFolder)

        'Chama macro para gerar arquivos PDF

        Sheets("Capa e Índice").Visible = True

        'Aba selecionada para ser gerado pdf

        ActiveWorkbook.SaveAs Filename:=strWindowsFolder & "01-Capa.pdf"

        'Salva como pdf

        Sheets("Capa e Índice").Visible = False

        'Oculta Aba

        ChDir strWindowsFolder

        Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus

        'Abrir pasta selecionada

    End If

    ActiveWorkbook.SaveAs Filename:=Caminho & "\XXX.xlsm",
    FileFormat:=xlOpenXMLWorkbookMacroEnabled

    'Salva documento com nome original

    Application.ScreenUpdating = True

    'Liga Atualização de tela

    Application.DisplayAlerts = True

    'Liga Alertas

    MsgBox "Arquivos criados com sucesso"

End Sub

Sub ProcessFolders(strPath As String)

    Dim objFileSystem As Object

    Dim objFolder As Object

    Dim objFile As Object

    Dim objExcelFile As Object

    Dim objWorkbook As Excel.Workbook

    Dim strWorkbookName As String


    Set objFileSystem = CreateObject("Scripting.FileSystemObject")

    Set objFolder = objFileSystem.GetFolder(strPath)

    'Para cada arquivo xlsx é gerado um arquivo PDF

    For Each objFile In objFolder.Files

        strFileExtension = objFileSystem.GetExtensionName(objFile)

        If LCase(strFileExtension) = "xlsx" Then

            Set objExcelFile = objFile

            Set objWorkbook = Application.Workbooks.Open(objExcelFile.Path)


            strWorkbookName = Left(objWorkbook.Name, (Len(objWorkbook.Name) - Len(strFileExtension)) - 1)

            objWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath & strWorkbookName & ".pdf"


            objWorkbook.Close False

        End If

    Next


    'Gerar PDF para subpastas

    If objFolder.SubFolders.Count > 0 Then

        For Each objSubFolder In objFolder.SubFolders

            If ((objSubFolder.Attributes And 2) = 0) And ((objSubFolder.Attributes And 4) = 0) Then

                ProcessFolders (objSubFolder.Path)

            End If

        Next

    End If

End Sub
1
  • 1
    É possivel ser feito inclusive não precisa de nada fora o Excel, mas pode ser um pouco mais longo a resposta do que gostaria. Eu fiz uma aplicação a alguns anos que pega varios arquivos de excel, com varias sheets, range, arquivos de imagem e PDF e concatena no mesmo PDF no final. mas como noto que este post tem quase 1 mes de talvez já tenha solucionado. Caso não me de um toque q eu lhe ajudo com as ideias de como fazer isso. Alias grato pelo toque danieltakeshi, tem toda razão. Commented 6/12/2018 às 16:29

1 Resposta 1

1

Existe uma solução simples com a integração entre Excel e Acrobat:

Preparar os arquivos que seram "unidos"

Sub Combine_PDFs_Demo()
Dim strPDFs(0 To 2) As String
Dim bSuccess As Boolean
'Caminhos dos PDFs que vocês gerou
strPDFs(0) = "C:\Users\User\Desktop\Page1.pdf"
strPDFs(1) = "C:\Users\User\Desktop\Page5.pdf"
strPDFs(2) = "C:\Users\User\Desktop\Page10.pdf"

bSuccess = MergePDFs(strPDFs, "C:\Users\User\Desktop\MyNewPDF.pdf")

If bSuccess = False Then MsgBox "Falha ao combinar os PDFs", vbCritical, "Falha ao combinar os PDFs"
End Sub

Após isso, use a integração com o Acrobat para unir os arquivos que você gerou:

Private Function MergePDFs(arrFiles() As String, strSaveAs As String) As Boolean     
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim i As Integer
Dim iFailed As Integer

On Error GoTo NoAcrobat:
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")

objCAcroPDDocDestination.Open (arrFiles(LBound(arrFiles)))

    For i = LBound(arrFiles) + 1 To UBound(arrFiles)
        objCAcroPDDocSource.Open (arrFiles(i))
        If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
          MergePDFs = True
        Else
          iFailed = iFailed + 1
        End If
        objCAcroPDDocSource.Close
    Next i
objCAcroPDDocDestination.Save 1, strSaveAs
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing

NoAcrobat:
If iFailed <> 0 Then
    MergePDFs = False
End If
On Error GoTo 0
End Function

Lembre-se de adicionar a referência "Adobe Acrobat X.0 Control Type Library 1.0" para o correto funcionamento.

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .