VBA Access. Módulo para combinar PDF con GhostScript (Merge PDF).

Option Compare Database
Option Explicit

'   Requisitos:
'*  Referencia VBA Microsoft Scripting Runtime (filesystemobject)
'*  Postscript and PDF interpreter/renderer (GhostScript)
'   Descargar de https://www.ghostscript.com/ En este ejemplo se usa la version gs9.50 x64

'MaxFiles = 114. Según las pruebas, 114 es el número máximo de ficheros que es capaz de combinar la versión Ghostscript gs9.50 x64 <<< MergePDFs no tiene ese límite >>>
'Si se supera el máximo, el programa no da error, el PDF es legible pero no contendrá todos los ficheros a combinar
'En caso de usar otra versión de GhostScript se deberá ajustar MaxFiles y comprobar si la salida del PDF es correcta

'La función MergePDFs puede superar el máximo permitido de combinación (MaxFiles), mediante el uso de ficheros pdf temporales, que en el último paso se combinan en 1 solo.
'El máximo teórico de ficheros pdf posibles a combinar seria 114x114 = 12996 ficheros.
'En una de las pruebas se ha conseguido combinar más de 800 ficheros con el resultado de 1 pdf combinado de más de 30000 páginas y 1 hora aprox. de proceso

'Ejemplos de uso:
'>> sin mostrar progreso de ghostscript
'MergePDFs aFiles, txtFicheroSalida
'>> mostrando progreso de ghostscript
'MergePDFs aFiles, txtFicheroSalida, True

Public Const MAXFILES = 114

Public Function MergePDFs(ByRef aFiles() As String, ByVal OutputFile As String, ByVal FicheroExeGS As String, Optional FolderFonts As String = "", Optional bMostrarProgreso As Boolean = False, Optional bMantenerCalidad As Boolean = True, Optional ByVal MAXTEMPFILES As Integer = MAXFILES) As Boolean
On Error GoTo error
    Dim fso As New FileSystemObject
 
    Dim iFile, i, nTempFiles
    Dim File As Variant
 
    Dim PdfFiles As String
    Dim aPdfFiles() As String
 
    Dim TmpFolder As String
    Dim PdfTemp As String
    Dim aPdfTemps() As String
 
    If Not fso.FileExists(FicheroExeGS) Then
        MsgBox "No se ha encontrado el fichero ejecutable GhostScript '" & FicheroExeGS & "'", vbExclamation, ""
        MergePDFs = False
        GoTo Salir
    End If
 
    TmpFolder = CurrentProject.Path & "\Temp\" & GetWindowsUser
    If Not fso.FolderExists(TmpFolder) Then MakeDirFullPath TmpFolder
 
    DoCmd.Hourglass True
 
    'Creamos tantos ficheros temporales combinados como sean necesarios (máximo MaxFiles combinados por fichero temporal)
    iFile = 1
    nTempFiles = 0
    For i = 0 To UBound(aFiles)
        'construimos lista de ficheros a combinar en un fichero temporal para pasar como parametro a GhostScript
        If iFile <= MAXTEMPFILES Then
            PdfFiles = IIf(PdfFiles <> "", PdfFiles & " " & """" & aFiles(i) & """", """" & aFiles(i) & """")
        End If
     
        'si llega al máximo de ficheros temporales o al último de los ficheros, creamos el fichero pdf temporal
        If iFile = MAXTEMPFILES Or i = UBound(aFiles) Then
            PdfTemp = TmpFolder & "\gsTmp_" & nTempFiles & ".pdf"
         
            'guardamos la lista de ficheros temporales creados en un array de strings
            ReDim Preserve aPdfTemps(nTempFiles)
            aPdfTemps(nTempFiles) = PdfTemp
            nTempFiles = nTempFiles + 1
         
            SysCmd acSysCmdSetStatus, "Combinando " & iFile & " ficheros a fichero temporal '" & PdfTemp & "'"
            MergePDFs = RunGhostScript(PdfFiles, PdfTemp, FicheroExeGS, FolderFonts, bMostrarProgreso, bMantenerCalidad)
            If Not MergePDFs Then GoTo Salir
         
            'reiniciamos lista de ficheros a combinar
            iFile = 0
            PdfFiles = ""
        End If
        iFile = iFile + 1
    Next
 
    If fso.FileExists(OutputFile) Then fso.DeleteFile (OutputFile)
    'Combinamos todos los ficheros temporales en el fichero de salida
    If UBound(aPdfTemps) > 0 Then
        'construimos la lista de ficheros a combinar para pasar como parametro a GhostScript. Los ficheros a combinar son el array donde tenemos almacenados los pdf temporales creados.
        PdfFiles = ""
        For i = 0 To UBound(aPdfTemps)
            PdfFiles = IIf(PdfFiles <> "", PdfFiles & " " & """" & aPdfTemps(i) & """", """" & aPdfTemps(i) & """")
        Next
     
        SysCmd acSysCmdSetStatus, "Combinando " & i & " ficheros temporales a fichero final '" & OutputFile & "'"
        MergePDFs = RunGhostScript(PdfFiles, OutputFile, FicheroExeGS, FolderFonts, bMostrarProgreso, bMantenerCalidad)
     
        'eliminar ficheros temporales
        For i = 0 To UBound(aPdfTemps)
            fso.DeleteFile aPdfTemps(i)
        Next
    Else
        'Solo hay 1 fichero temporal. No hace falta combinar, movemos/renombramos el fichero como fichero de salida
        fso.MoveFile aPdfTemps(0), OutputFile
    End If
 
Salir:
    Set fso = Nothing

    SysCmd acSysCmdClearStatus
    DoCmd.Hourglass False

Exit Function
Resume
error:
    DoCmd.Hourglass False
    MergePDFs = False
    MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function

Private Function RunGhostScript(ByVal PdfFiles As String, ByVal OutputFile As String, ByVal FicheroExeGS As String, Optional FolderFonts As String = "", Optional bMostrarProgreso As Boolean = False, Optional bConsolaBlanca As Boolean = True, Optional bMantenerCalidad As Boolean = True) As Boolean
On Error GoTo error
    Dim res As Integer
    Dim wsh As Object
    Dim windowStyle As Integer
    Dim waitOnReturn As Boolean

    Dim gsCmd As String
 
    If bMantenerCalidad Then
        gsCmd = """" & FicheroExeGS & """" & IIf(bMostrarProgreso, "", " -q") & IIf(FolderFonts <> "", " -sFONTPATH=""" & FolderFonts & """ -dEmbedAllFonts=true", "") & _
        " -dSAFER -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -dAutoRotatePages=/None -dAutoFilterColorImages=false -dAutoFilterGrayImages=false -dColorImageFilter=/FlateEncode" & _
        " -dGrayImageFilter=/FlateEncode -dDownsampleMonoImages=false -dDownsampleGrayImages=false -sOutputFile=""" & OutputFile & """" & " " & PdfFiles
    Else
        gsCmd = """" & FicheroExeGS & """" & IIf(bMostrarProgreso, "", " -q") & IIf(FolderFonts <> "", " -sFONTPATH=""" & FolderFonts & """ -dEmbedAllFonts=true", "") & _
        " -dSAFER -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=""" & OutputFile & """" & " " & PdfFiles
    End If

    'windowStyle: 0 oculta ventana shell, 1 muestra ventana shell
    windowStyle = IIf(bMostrarProgreso, 1, 0)
    waitOnReturn = True
    Set wsh = VBA.CreateObject("WScript.Shell")
    res = wsh.Run(gsCmd, windowStyle, waitOnReturn)
    Set wsh = Nothing

    'res=0 proceso completo finalizado OK
    RunGhostScript = (res = 0)

Exit Function
error:
    DoCmd.Hourglass False
    RunGhostScript = False
    MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function

Public Function MakeDirFullPath(ByVal sPath As String) As Boolean
On Error GoTo error
    'crear todo el path de un directorio
    If Right(sPath, 1) = "\" Then
        sPath = Left(sPath, Len(sPath) - 1)
    End If
    Dim SplitPath() As String
    SplitPath = Split(sPath, "\")
    Dim Value As Integer
    Dim Merge As String
    For Value = 0 To UBound(SplitPath)
        If Value <> 0 Then
            Merge = Merge & "\"
        End If
        Merge = Merge & SplitPath(Value)
        If Dir(Merge, vbDirectory) = "" Then
            MkDir Merge
        End If
    Next
    SetAttr sPath, vbNormal
    MakeDirFullPath = True
 
Exit Function
error:
    MakeDirFullPath = False
    Debug.Print Err.Description
End Function

Public Function GetWindowsUser() As String
On Error GoTo error
    Dim sUsername As String
    Dim objNetwork As Object
 
    sUsername = Environ$("username")
 
    If sUsername = "" Then
        Set objNetwork = CreateObject("WScript.Network")
        sUsername = objNetwork.UserName
        Set objNetwork = Nothing
    End If

    GetWindowsUser = sUsername
 
Exit Function
error:
    Debug.Print Err.Description
    GetWindowsUser = ""
End Function