我如何使用 VBA 代码合并多个 pdf 文件

Question

我有一个包含多个 pdf 文件路径的表...现在我需要一个 VBA 代码来将所有这些文件合并到一个 pdf 文件中。 注意：-要合并的 pdfs 文件的数量会不时变化。

Sub Combine_PDFs_Demo()
Dim i As Integer 'counter for records
Dim x As Integer
Dim strNPDF As String
Dim bSuccess As Boolean
Dim DB As Database
Dim RS As Recordset
Set DB = CurrentDb
Set RS = DB.OpenRecordset("SELECT[paths] from scantemp ")
strNPDF = CurrentProject.Path & "\request_pic\" & (request_no) & ".pdf"
RS.MoveLast
DB.Recordsets.Refresh
i = RS.RecordCount
RS.MoveFirst
Dim strPDFs() As String
ReDim strPDFs(0 To i)
strPDFs(0) = RS![paths]
RS.MoveNext
For i = 1 To i - 1
strPDFs(i) = RS![paths]
bSuccess = MergePDFs(strPDFs, strNPDF)
Next i
If bSuccess = False Then MsgBox "Failed to combine all PDFs", vbCritical, "Failed to Merge PDFs"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp" 'delete all paths from table scantemp after converted it to pdf
DoCmd.SetWarnings True
  RS.Close
    Set RS = Nothing`enter code here`

Answer 1

public 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:
'Initialize the Acrobat objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
 'Open Destination, all other documents will be added to this and saved with
'a new filename
objCAcroPDDocDestination.Open (arrFiles(LBound(arrFiles))) 'open the first file
 'Open each subsequent PDF that you want to add to the original
  'Open the source document that will be added to the destination
    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
          'failed to merge one of the PDFs
          iFailed = iFailed + 1
        End If
        objCAcroPDDocSource.Close
    Next i
objCAcroPDDocDestination.save 1, strSaveAs 'Save it as a new name
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing

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

Answer 2

这使用 PDF 或 PS 文件列表来创建一个 PDF。抱歉，它在 VB.net 中，我真的没有时间转换。但它说明了这个概念，如果你能涉水过它。基本上，您将选项和文件名写入文本文件，然后将该文件用作 Ghostscript 的参数。

    Private Shared Sub ConvertToPDF(ByVal PSPathFileList As List(Of String), _
                             ByVal PDFPathName As String, _
                             ByVal WaitForExit As Boolean, ByVal DeletePS As Boolean)

        'check that all files exist
        PSPathFileList.ForEach(AddressOf CheckFiles)

        'check old pdf file
        If IO.File.Exists(PDFPathName) Then
            Throw New ApplicationException( _
                "PDF cannot be created. File already exists: " & PDFPathName)
        End If

        'convert engine
        Dim myProcInfo As New ProcessStartInfo
        myProcInfo.FileName = DanBSolutionsLocation & "Misc\GhostScript\GSWIN32C.EXE"
        Debug.Print(myProcInfo.FileName)

        'write file names to text file as the list can be very long
        Dim tempPath As String = IO.Path.GetDirectoryName(PSPathFileList.Item(0))
        Dim fiName2 As String = tempPath & IO.Path.GetFileNameWithoutExtension(PDFPathName) & ".txt"

        Dim ft As New StreamWriter(fiName2)
        ft.WriteLine("-sDEVICE=pdfwrite -q -dSAFER -dNOPAUSE -sOUTPUTFILE=""" & PDFPathName & """ -dBATCH ")
        For i As Long = 0 To PSPathFileList.Count - 1
            ft.WriteLine(Chr(34) & PSPathFileList.Item(i) & Chr(34))
        Next
        ft.Close()

        'set args to text file
        myProcInfo.Arguments = """@" & fiName2 & """"

        'set up for output and errors
        myProcInfo.UseShellExecute = False
        myProcInfo.RedirectStandardOutput = True
        myProcInfo.RedirectStandardError = True
        Debug.Print(myProcInfo.Arguments)

        'do the conversion
        Dim myProc As Process = Process.Start(myProcInfo)

        Debug.Print(myProc.StandardOutput.ReadToEnd)
        Debug.Print(myProc.StandardError.ReadToEnd)

        If WaitForExit Then
            'wait for finish; (no more than 60 seconds)
            myProc.WaitForExit(60000)

            'delete PS
            If DeletePS Then
                PSPathFileList.ForEach(AddressOf DeleteFiles)
            End If
        End If

    End Sub

这是单个 PS 到 PDF 的 VBA 代码。所以在上面的 VB.net 和下面的这个之间，希望你能挽救一些有用的东西。

Private Sub printToPdfDemo()

    'verify printer setup
    'be sure to install the PsPrinterInstall module
    Call PSPrinterSetup

    Dim svPsFileName As String
    Dim svPDFName As String

    'define names
    svPsFileName = "C:\Temp\Input 1.ps"
    svPDFName = "C:\Temp\Output 1.PDF"

    'save current printer
    Dim PrinterInUse As String
    PrinterInUse = Application.ActivePrinter

    'print to PS
    'If Fso.FileExists(svPsFileName) Then Call Fso.DeleteFile(svPsFileName)
    Worksheets(1).PrintOut ActivePrinter:=PSPrinterName, PrintToFile:=True, _
        PrToFileName:=svPsFileName

    'revert to saved printer name
    Application.ActivePrinter = PrinterInUse

    'convert
    Call ConvertToPDF(svPsFileName, svPDFName)
End Sub


Sub ConvertToPDF(ByVal svPsFileName As String, ByVal svPDFName As String)
    Dim fso As New FileSystemObject
    'Dim Fso: Set Fso = CreateObject("Scripting.FileSystemObject")
    Dim folGS As Folder
    Dim lcCmd As String

    'check inputs
    If svPsFileName = "" Or svPDFName = "" Then
        Call MsgBox("PS file name or PDF file name is blank in ""ConvertToPDF"" macro", vbExclamation, "Error! Missing Inputs")
        Exit Sub
    End If

    'check file
    If Not fso.FileExists(svPsFileName) Then
        Call MsgBox(svPsFileName & " file is not found", vbExclamation, "Error! Missing File")
        Exit Sub
    End If

    'check variable
    If DanBSolutionsLocation = "" Then DanBSolutionsLocation = GetDanBSolutionsLocation

    'delete old file
    If fso.FileExists(svPDFName) Then Call fso.DeleteFile(svPDFName)

    'get files
    Set folGS = fso.GetFolder(DanBSolutionsLocation & "Misc\GhostScript\") 'S:\DanB Solutions\Misc\GhostScript\GSWIN32C.EXE

    'GS command
    lcCmd = folGS.ShortPath & "\GSWIN32C.EXE " & _
    "-q -dNOPAUSE -I" & folGS.ShortPath & "\lib;./fonts " & _
    "-sFONTPATH=./fonts -sFONTMAP=" & folGS.ShortPath & "\lib\FONTMAP.GS " & _
    "-sDEVICE=pdfwrite -sOUTPUTFILE=" & """" & svPDFName & """" _
    & " -dBATCH " & """" & svPsFileName & """"

    'convert
    Debug.Print lcCmd
    Call ShellWait(lcCmd)

    'delete PS
    If fso.FileExists(svPDFName) Then fso.DeleteFile (svPsFileName)

End Sub