Merging Files only works every second time Excel VBA

Hi,

I have some VBA code to merge pdf files into a single PDF.

I have the following code…

Option Explicit

Sub Test_PDFCreatorCombine2()
Dim fn(0 To 3) As String, s As String

fn(0) = ThisWorkbook.Path & “\P1.pdf”
fn(1) = ThisWorkbook.Path & “\P2.pdf”
fn(2) = ThisWorkbook.Path & “\P3.pdf”
fn(3) = ThisWorkbook.Path & “\P4.pdf”
s = ThisWorkbook.Path & “\PDFCreatorCombined.pdf”

PDFCreatorCombine fn(), s

If vbYes = MsgBox(“Open Merged Data File? " & vbCr & vbCr & _
s, vbYesNo + vbQuestion, “Open?”) Then Shell (“cmd /c " & “””” & s & “”"")
End Sub

’ Older version examples by Ken Puls,

’ Macro Purpose: Print to PDF file using PDFCreator v2.3.2, Kenneth Hobson, Oct. 8, 2016

’ Designed for early bind, set reference to: PDFCreator - Your OpenSource PDF Solution
’ sPDFName() assumed to be 0 index based string array.
Sub PDFCreatorCombine(sPDFName() As String, sMergedPDFname As String, _
Optional tfKillMergedFile As Boolean = True)
Dim oPDF As PdfCreatorObj
Dim q As Queue
Dim pj As PrintJob
Dim i As Integer, ii As Integer
Dim fso As Object, tf As Boolean
Dim s() As String

On Error GoTo EndSub
Set fso = CreateObject(“Scripting.FileSystemObject”)
If tfKillMergedFile And fso.FileExists(sMergedPDFname) Then Kill sMergedPDFname

For i = 0 To UBound(sPDFName)
If fso.FileExists(sPDFName(i)) Then
ii = ii + 1
ReDim Preserve s(1 To ii)
s(ii) = sPDFName(i)
End If
Next i

Set q = New Queue
With q
.Initialize

  Set oPDF = New PdfCreatorObj
  
  
  For i = 1 To UBound(s)
    oPDF.AddFileToQueue s(i)
  Next i

’ tf = .WaitForJobs(i, 5) 'Wait 5 seconds for jobs to queue

  .MergeAllJobs
   
  Set pj = q.NextJob
  With pj
    .SetProfileByGuid "DefaultGuid"
    .SetProfileSetting "Printing.PrinterName", "PDFCreator"
    .SetProfileSetting "Printing.SelectPrinter", "SelectedPrinter"
    .SetProfileSetting "OpenViewer", "false"
    .SetProfileSetting "OpenWithPdfArchitect", "false"
    .SetProfileSetting "ShowProgress", "false"
    .ConvertTo sMergedPDFname
  End With

End With
EndSub:
If Not q Is Nothing Then q.ReleaseCom
Set q = Nothing
Set pj = Nothing
Set oPDF = Nothing

End Sub

This works perfectly every second time I run it with every other time only result showing the combined PDF to only containing the contains of P1.pdf

However it appears that it is only when the same files are attempted to be merged for a second time that this occurs.

So I setup a second routine which merges P5,6,7,8 together. When I open the file I can

merge P1-4 perfect
merge p5-8 perfect
merge p1-4 - only P1 in merged doc
merge p5-8 only P5 in merged doc
merge p5-8 perfect
merge p5-8 only P5 in merged doc
merge P1-4 perfect

Closing and reopening excel at any time though the sequence will reset and work the first time the files are merged again.

I also have this exact issue. Any help would be much appreciated.

I also have this exact issue PDFCreator-3_3_2. Do you have any solutions?

Hello everyone

I have same issue, and find a trick that work for me.
Only need to use a function to test if PDFMerge is successfull, if not, run it again.
I hope this help you

Have a nice day!

This is the code.

Option Explicit
'-------------------------------------------------------------
'  Combinar archivos PDF usando PDFCreator_COM desde Excel VBA
'  Codigo: Emilio Alcalá 
'  Fecha: 22/03/2019
'  Problema: Desde Excel al intentar combinar
'            archivos, funciona una vez y otra no
'  Solución: Correr PDFMerge1 la primera vez, si esto falla
'            correr por segunda vez PDFMerge1
'-------------------------------------------------------------
Private Sub MergePDFs()
    Dim File1 As String, File2 As String, Path1 As String, PdfFile As String
    Path1 = "C:\Pdfs\"
    File1 = Path1 & "File1.pdf" 
    File2 = Path1 & "File2.pdf" 
    PdfFile = Path1 & "MergedFile.pdf"
    Files = Array(File1, File2)
    Call PDFMerge(Files, PdfFile)
End Sub

Private Sub PDFMerge(FilesArray As Variant, OutputFullFileName As Variant)
    Dim PdfOk As Boolean
    PdfOk = PDFMerge1(FilesArray, OutputFullFileName)
    If Not PdfOk Then
        PdfOk = PDFMerge1(FilesArray, OutputFullFileName)
        If Not PdfOk Then
            MsgBox "No se pudo crear el archivo:" & vbCrLf & OutputFullFileName
        End If
    End If
End Sub

Private Function PDFMerge1(FilesArray As Variant, OutputFullFileName As Variant) As Boolean
    Dim Q As New PDFCreator_COM.Queue, PdfCreatorObj As New PDFCreator_COM.PdfCreatorObj, pJob As PDFCreator_COM.printJob
    Dim a As Integer, b As Integer, n As Integer, i As Integer
    PDFMerge1 = False
    a = LBound(FilesArray)
    b = UBound(FilesArray)
    n = b - a + 1
    On Error Resume Next
    Q.Initialize
    For i = a To b
        PdfCreatorObj.AddFileToQueue FilesArray(i)
    Next i
    If Q.WaitForJobs(n, n * 3) = False Then
        GoTo Finalizar
    End If
    Q.MergeAllJobs
    Set pJob = Q.NextJob
    pJob.SetProfileByGuid ("DefaultGuid")
    pJob.ConvertTo OutputFullFileName
    
Finalizar:
    If (Not pJob.IsFinished Or Not pJob.IsSuccessful) Then
        PDFMerge1 = False
    Else
        MsgBox "Se creó el archivo:" & vbCrLf & OutputFullFileName
        PDFMerge1 = True
    End If
    Q.ReleaseCom
    Set pJob = Nothing
End Function
1 Like

Hello. I struggled with the same problem recently and found a workaround, that gives result every time. Thought, that it might be helpful to post answer here. The recursive function below will use difference in file sizes and define, whether the file correct or not. It will generate file 2 or 3 times, and the last attempt will give the file needed.


Function PDFMerge_PDFCreator(arrFiles() As String, ByVal SvAs As String, _

Optional last_filesize As Long = 0, Optional run_counter As Long = 1) As Boolean

    ' __Macro to merge specified .pdf files and save as one file__

   

    ' In order for this to work, PDFCreator must be installed.

    ' This code is late binding, no need to set up reference to PDFCreator_COM.

    ' This function is recursive. Do not set optional arguments at function call.

    ' Optional arguments are for internal use of the function itself.

       

    ' Variables for PDFCreator

    Dim oPDF As Object

    Dim queue As Object

    Dim job As Object

   

    Dim output_filesize As Long

   

    ' Enable error handling for missing PDFCreator

    On Error GoTo NoPDFCreator:

   

    ' Create PDFCreator Object

    Set oPDF = CreateObject("PDFCreator.PDFCreatorObj")

   

    ' Create queue object to collect print jobs

    Set queue = CreateObject("PDFCreator.JobQueue")

   

    ' Enable default error handling

    On Error GoTo 0

   

    ' If first run of the function

    If run_counter = 1 Then

        ' If PDF Creator is already running

        If oPDF.IsInstanceRunning Then

             ' Release library

             ' To avoid error that instance of

             ' PDFCreator is currently running

             queue.ReleaseCom

        End If

   

        ' Init queue (run PDFCreator)

        queue.Initialize

    End If

   

    ' Add each PDF file path in array to PDFCreator Queue

    For i = LBound(arrFiles) To UBound(arrFiles)

        oPDF.AddFileToQueue arrFiles(i)

    Next i

   

    ' Merge print jobs

    queue.MergeAllJobs

     

    ' Get a reference to the next nob

    Set job = queue.NextJob

       

    ' Set file conversion profile to default

    job.SetProfileByGuid ("DefaultGuid")

   

    ' Start file conversion and save file

    job.ConvertTo (SvAs)

    ' Get file size of output file

    output_filesize = FileLen(SvAs)

    

    ' Workaround for PDF Creator Merge problem

    ' (when it merge files correctly only every 2nd time)

    ' If first run of function

    If run_counter = 1 Then

   

        ' Update run counter

        run_counter = run_counter + 1

   

        ' Call this function again to being able to compare file sizes

        Call PDFMerge_PDFCreator(arrFiles, SvAs, output_filesize, run_counter)

    Else

        ' If output file size in current attempt less than in previous

        If output_filesize < last_filesize Then

       

            ' Update run counter

            run_counter = run_counter + 1

       

            ' Call this function again

            Call PDFMerge_PDFCreator(arrFiles, SvAs, output_filesize, run_counter)

        Else

            GoTo Success

        End If

    End If

   

    Exit Function

NoPDFCreator:

    MsgBox "PDF file merging failed." & vbCrLf & _

    "PDFCreator must be installed.", vbCritical, Title:="Error"

    ' Return value of failed export

    PDFMerge_PDFCreator = False

   

    Exit Function

   

Success:

    ' _________________________

    ' Cleanup

    ' Release library

    queue.ReleaseCom

   

    ' Clear job

    Set job = Nothing

   

    ' Clear queue

    Set queue = Nothing

   

    ' Clear PDF Creator object

    Set oPDF = Nothing

    ' _________________________

       

    ' Return value of successful export

    PDFMerge_PDFCreator = True

End Function