Merging Files only works every second time Excel VBA


#1

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.


Any idea if the VBA bug "works every second time" will be adressed?
#2

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


#3

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


#4

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