Mescla multiplos pdfs em so Pdf

Bom dia!!
Meus Caros estou sempre por aqui pesquisando e baixando codigos mais hoje me deparei com um problema
que na conseguir achar nas pesquisas cheguei perto mais nao tinha mais o arquivo de exemplo.

tentei de varias maneiras, tenhos os codigos mais a mensagens que exibi é que nao consegui mesclar os Pdfs
achei este post

https://www.maximoaccess.com/t15403-mescla-multiplos-pdf-s-em-um#116814


estou usando este codigo

Private Sub Comando5_Click()
Dim ArrayDePDFs(0 To 2) As String, i As Integer
Dim sMaster As String
Dim bSuccess As Boolean
'Caminhos dos PDFs que vocês gerou

csql = "SELECT * FROM RELATORIOCOMPROVPIXCAIXA WHERE [DATAS]= #" & Format(Forms!DIALOGOCAIXA![DataDeInício], "mm/dd/yyyy") & "#"
Set dyntempven = CurrentDb.OpenRecordset(csql, dbOpenDynaset)

Do While Not dyntempven.EOF

For i = LBound(ArrayDePDFs) To UBound(ArrayDePDFs) - 1

ArrayDePDFs(i) = dyntempven!LocalArquivo

dyntempven.MoveNext

Next i


Loop

sMaster = Application.CurrentProject.path & "\COMPROVANTE PIX\" & "RELCOMPROVPIX" & Format(Date, "DDMMYY") & ".pdf"
bSuccess = MergePDFs(ArrayDePDFs, sMaster)
If bSuccess = False Then MsgBox "Falha ao combinar os PDFs", vbCritical, "Falha ao combinar os PDFs"

End Sub


e uso essa funcao:


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

e essa mensagem que aparece quando clico em visualizar

Bom dia!!
Uma outra opcao que eu queria era um relario onde eu tenho classicado por codigo os comprovantes que estao em PFD tipo relatorio de etiqueta.
tenho as informais mais nao exibe os pdfs.

O Objetivo do Relatorio é de exibir um relatorio em PDF que exibe os comprovantes que estao salvos em Pdfs como se eles fossem imagens
de cada registro filtrados da data selecionada

Sem solução.
Tópico fechado.

Bom dia!!
Preciso continuar esse Tópico precisso dessa solução
alguem para me ajudar nesse codigo

achei este post mais esta desativado não exibe mais

https://www.maximoaccess.com/t15403-mescla-multiplos-pdf-s-em-um#116814

Tem essa opção com pdfcreator

Código:


Sub Test_PDFCreatorCombine()
  Dim fn(0 To 1) As String
  fn(0) = "C:\temp\Pdf\Joao.pdf"
  fn(1) = "C:\temp\Pdf\maria.pdf"
  PDFCreatorCombine fn(), "C:\temp\Pdf\PDFCreatorCombined.pdf"
End Sub


Sub PDFCreatorCombine(sPDFName() As String, sMergedPDFname As String)
  Dim oPDF As PDFCreator_COM.PdfCreatorObj, q As PDFCreator_COM.Queue
  Dim pj As PrintJob
  Dim v As Variant, i As Integer

  Set q = Nothing
  Set q = New PDFCreator_COM.Queue
  q.Initialize
  If LBound(sPDFName) = 0 Then
    q.WaitForJobs UBound(sPDFName) + 1, 1
    Else
    q.WaitForJobs UBound(sPDFName), 1
  End If
  
  Set oPDF = New PDFCreator_COM.PdfCreatorObj
 
  i = 0
  For Each v In sPDFName()
    oPDF.PrintFile v
    i = i + 1
  Next v
  
  q.MergeAllJobs
  
  Set pj = q.NextJob
  pj.SetProfileByGuid ("DefaultGuid")
  pj.ConvertTo sMergedPDFname
EndNow:
  q.ReleaseCom
End Sub



Bon dia!
Basole muito obrigado pela atenção!!!

vou testar

Ah, tem essa outra opção com o PdfTk com linha de comando.

pdflabs.com/tools/pdftk-the-pdf-toolkit

Não precisa nem instalar. Só precisa que os arquivos pdftk.exe e libiconv2.dll sejam salvos na pasta Windows\system32 para win32,
ou para win64 o arquivo pdftk.exe em Windows\system32 e o libiconv2.dl na pasta windows\sysWOW64

Exemplo:

Código:


Sub Mesclar_PDF()
    Dim File1N
    Dim File2N
    Dim TmpN
    Dim WkPath      As String
    Dim strFullCde  As String
    Const str_NAME_OF_EXE = "Pdftk"

    File1N = "C:\temp\Pdf\Seu_PDF_1.pdf"
    File2N = "C:\temp\Pdf\Seu_PDF_2.pdf"
    TmpN = "Tmp.pdf"
    WkPath = "C:\temp\Pdf"

    File1N = File1N
    File2N = File2N

    TmpN = VBA.Chr(34) & WkPath & "\" & TmpN & VBA.Chr(34)

    strFullCde = "cmd /c " & str_NAME_OF_EXE & " " & File1N & " " & File2N & " cat OUTPUT " & TmpN

    VBA.CreateObject("WScript.Shell").Run strFullCde, vbHide, True

    If VBA.Len(VBA.Dir(VBA.Replace(TmpN, VBA.Chr(34), ""), vbArchive)) <> "" Then

        VBA.CreateObject("WScript.Shell").Run TmpN, vbHide, True

    End If
    
End Sub


Boa noite!!

Basole!! Muito Obrigado Novamente!!

mais exibe essa mensagem de erro

Aqui pra mim rodou perfeitamente.

Mostre o seu codigo, para ver se encontramos alguma inconsistência

Bom dia!!

esse codigo

Sub Mesclar_PDF()
Dim fn(0 To 50) As String
Dim File1N
Dim File2N
Dim TmpN
Dim WkPath As String
Dim strFullCde As String
Const str_NAME_OF_EXE = "Pdftk"


csql = "SELECT * FROM RELATORIOCOMPROVPIXCAIXA WHERE [DATAS]= #" & Format(Forms!DIALOGOCAIXA![DataDeInício], "mm/dd/yyyy") & "#"
Set dyntempven = CurrentDb.OpenRecordset(csql, dbOpenDynaset)

Do While Not dyntempven.EOF

For I = LBound(fn) To dyntempven.RecordCount - 1
fn(I) = dyntempven!LocalArquivo
Me("PDF" & I).Value = dyntempven!LocalArquivo

dyntempven.MoveNext

Next I


Loop

'PDFCreatorCombine fn(), Application.CurrentProject.path & "\COMPROVANTE PIX\" & "RELCOMPROVPIX" & Format(Date, "DDMMYY") & ".pdf"







'File1N = "C:\temp\Pdf\Seu_PDF_1.pdf"
'File2N = "C:\temp\Pdf\Seu_PDF_2.pdf"

TmpN = "RELCOMPROVPIX" & Format(Date, "DDMMYY") & ".pdf"
WkPath = Application.CurrentProject.path & "\COMPROVANTE PIX\"


'File1N = File1N
'File2N = File2N

TmpN = VBA.Chr(34) & WkPath & "\" & TmpN & VBA.Chr(34)


strFullCde = "cmd /c " & str_NAME_OF_EXE & " fn " & " cat OUTPUT " & TmpN

' strFullCde = "cmd /c " & str_NAME_OF_EXE & " " & File1N & " " & File2N & " cat OUTPUT " & TmpN

VBA.CreateObject("WScript.Shell").Run strFullCde, vbHide, True

If VBA.Len(VBA.Dir(VBA.Replace(TmpN, VBA.Chr(34), ""), vbArchive)) <> "" Then

VBA.CreateObject("WScript.Shell").Run TmpN, vbHide, True

End If

End Sub