VBA, объединить PDF файлы в один PDF файл

Ответ 1

Вам необходимо установить/использовать Adobe Acrobat.

Я использовал ссылки этого ресурса re

https://wwwimages2.adobe.com/content/dam/acom/en/devnet/acrobat/pdfs/iac_api_reference.pdf

EDIT: замена массива для автоматически генерируемого (в основном, основного PDF файла, заданного пользователем) списком путей к pdf файлам, которые вы хотите вставить в первичный pdf файл)

Вы можете использовать что-то вроде ниже, чтобы создать сборник документов, который будет вставлен в ваш основной документ. Первым файлом в collection будет file который вы вставляете, как и в первом примере. Затем назначьте путь папки к папке с files PDF, которые вы хотели бы видеть вставленными в ваш основной документ, в inputDirectoryToScanForFile. loop в этом коде добавит путь к каждому файлу PDF в этой папке в вашу collection. Это пути, которые позже используются в вызовах API adobe для вставки pdf в ваш основной.

Sub main()

Dim myCol                               As Collection
Dim strFile                             As String
Dim inputDirectoryToScanForFile         As String
Dim primaryFile                         As String

    Set myCol = New Collection

    primaryFile = "C:\Users\Evan\Desktop\myPDf.Pdf"

    myCol.Add primaryFile

    inputDirectoryToScanForFile = "C:\Users\Evan\Desktop\New Folder\"

    strFile = Dir(inputDirectoryToScanForFile & "*.pdf")

    Do While strFile <> ""
        myCol.Add strFile
        strFile = Dir
    Loop
End Sub

Код, который берет первичный файл и вставляет другие файлы PDF в этот файл:

Sub main()

    Dim arrayFilePaths() As Variant
    Set app = CreateObject("Acroexch.app")

    arrayFilePaths = Array("C:\Users\Evan\Desktop\PAGE1.pdf", _
                            "C:\Users\Evan\Desktop\PAGE2.pdf", _
                            "C:\Users\Evan\Desktop\PAGE3.pdf")

    Set primaryDoc = CreateObject("AcroExch.PDDoc")
    OK = primaryDoc.Open(arrayFilePaths(0))
    Debug.Print "PRIMARY DOC OPENED & PDDOC SET: " & OK

    For arrayIndex = 1 To UBound(arrayFilePaths)
        numPages = primaryDoc.GetNumPages() - 1

        Set sourceDoc = CreateObject("AcroExch.PDDoc")
        OK = sourceDoc.Open(arrayFilePaths(arrayIndex))
        Debug.Print "SOURCE DOC OPENED & PDDOC SET: " & OK

        numberOfPagesToInsert = sourceDoc.GetNumPages

        OK = primaryDoc.InsertPages(numPages, sourceDoc, 0, numberOfPagesToInsert, False)
        Debug.Print "PAGES INSERTED SUCCESSFULLY: " & OK

        OK = primaryDoc.Save(PDSaveFull, arrayFilePaths(0))
        Debug.Print "PRIMARYDOC SAVED PROPERLY: " & OK

        Set sourceDoc = Nothing
    Next arrayIndex

    Set primaryDoc = Nothing
    app.Exit
    Set app = Nothing
    MsgBox "DONE"
End Sub

Ответ 2

Это мое понимание вашего вопроса:

Требования:

• Объединенная серия PDF файлов, расположенных в одной и той же папке книги, содержащей процедуру

• Имена файлов Pdf переходят от firstpdf1.pdf к firstpdfn.pdf где n - общее количество файлов, которые должны быть объединены

Давайте рассмотрим ваш исходный код:

• Все переменные должны быть объявлены:

Dim objCAcroPDDocSource as object, objCAcroPDDocDestination as object

• В этой строке отсутствует разделитель путей "\":

PDFfileName = Dir(ThisWorkbook.Path & "firstpdf" & n & ".pdf")

Он должен быть PDFfileName = Dir(ThisWorkbook.Path & "\" & "firstpdf" & n & ".pdf")

• Поэтому эта строка всегда возвращает "" (в файле ThisWorkbook.Path файл pdf не найден):

If PDFfileName <> "" Then

Дополнительно:

• Эти строки вернутся: Error - 424 Object required для объектов objCAcroPDDocSource и objCAcroPDDocDestination не был инициализирован:

objCAcroPDDocSource.Open ThisWorkbook.Path & "pathwithpdfs" & PDFfileName

If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then

objCAcroPDDocSource.Close

• objCAcroPDDocDestination никогда не открывался.

Решения: эти процедуры используют библиотеку Adobe Acrobat

Библиотека Adobe Acrobat - ранняя граница

Для того, чтобы создать Reference Vb в Adobe библиотеку в редакторе VBA меню нажмите Tools "Ссылки then select the Adobe Acrobat Library in the dialog window then press the, in the dialog window then press the OK" кнопку.

Sub PDFs_Combine_EarlyBound()
Dim PdfDst As AcroPDDoc, PdfSrc As AcroPDDoc
Dim sPdfComb As String, sPdf As String
Dim b As Byte

    Rem Set Combined Pdf filename - save the combined pdf in a new file in order to preserve original pdfs
    sPdfComb = ThisWorkbook.Path & "\" & "Pdf Combined" & Format(Now, " mmdd_hhmm ") & ".pdf"   'change as required

    Rem Open Destination Pdf
    b = 1
    sPdf = ThisWorkbook.Path & "\" & "firstpdf" & b & ".pdf"
    Set PdfDst = New AcroPDDoc
    If Not (PdfDst.Open(sPdf)) Then
        MsgBox "Error opening destination pdf:" & vbCrLf _
            & vbCrLf & "[" & sPdf & "]" & vbCrLf _
            & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
        Exit Sub
    End If

    Do

        Rem Set & Validate Source Pdf
        b = b + 1
        sPdf = ThisWorkbook.Path & "\" & "firstpdf" & b & ".pdf"
        If Dir(sPdf, vbArchive) = vbNullString Then Exit Do

        Rem Open Source Pdf
        Set PdfSrc = New AcroPDDoc
        If Not (PdfSrc.Open(sPdf)) Then
            MsgBox "Error opening source pdf:" & vbCrLf _
                & vbCrLf & "[" & sPdf & "]" & vbCrLf _
                & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
            GoTo Exit_Sub
        End If

        With PdfDst

            Rem Insert Source Pdf pages
            If Not (.InsertPages(-1 + .GetNumPages, PdfSrc, 0, PdfSrc.GetNumPages, 0)) Then
                MsgBox "Error inserting source pdf:" & vbCrLf _
                    & vbCrLf & "[" & sPdf & "]" & vbCrLf _
                    & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
                GoTo Exit_Sub
            End If

            Rem Save Combined Pdf
            If Not (.Save(PDSaveFull, sPdfComb)) Then
                MsgBox "Error saving combined pdf:" & vbCrLf _
                    & vbCrLf & "[" & sPdfComb & "]" & vbCrLf _
                    & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
                GoTo Exit_Sub
            End If

            PdfSrc.Close
            Set PdfSrc = Nothing

        End With

'        sPdf = Dir(sPdf, vbArchive)
'    Loop While sPdf <> vbNullString
    Loop

    MsgBox "Pdf files combined successfully!", vbExclamation

Exit_Sub:
    PdfDst.Close

   End Sub

Библиотека Adobe Acrobat - Поздняя ссылка

Нет необходимости создавать ссылку Vb для библиотеки Adobe

Sub PDFs_Combine_LateBound()
Dim PdfDst As Object, PdfSrc As Object
Dim sPdfComb As String, sPdf As String
Dim b As Byte

    Rem Set Combined Pdf filename - save the combined pdf in a new file in order to preserve original pdfs
    sPdfComb = ThisWorkbook.Path & "\" & "Pdf Combined" & Format(Now, " mmdd_hhmm ") & ".pdf"   'change as required

    Rem Open Destination Pdf
    b = 1
    sPdf = ThisWorkbook.Path & "\" & "firstpdf" & b & ".pdf"
    Set PdfDst = CreateObject("AcroExch.PDDoc")
    If Not (PdfDst.Open(sPdf)) Then
        MsgBox "Error opening destination pdf:" & vbCrLf _
            & vbCrLf & "[" & sPdf & "]" & vbCrLf _
            & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
        Exit Sub
    End If

    Do

        Rem Set & Validate Source filename
        b = b + 1
        sPdf = ThisWorkbook.Path & "\" & "firstpdf" & b & ".pdf"
        If Dir(sPdf, vbArchive) = vbNullString Then Exit Do

        Rem Open Source filename
        Set PdfSrc = CreateObject("AcroExch.PDDoc")
        If Not (PdfSrc.Open(sPdf)) Then
            MsgBox "Error opening source pdf:" & vbCrLf _
                & vbCrLf & "[" & sPdf & "]" & vbCrLf _
                & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
            GoTo Exit_Sub
        End If

        With PdfDst

            Rem Insert Source filename pages
            If Not (.InsertPages(-1 + .GetNumPages, PdfSrc, 0, PdfSrc.GetNumPages, 0)) Then
                MsgBox "Error inserting source pdf:" & vbCrLf _
                    & vbCrLf & "[" & sPdf & "]" & vbCrLf _
                    & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
                GoTo Exit_Sub
            End If

            Rem Save Combined Pdf
            If Not (.Save(1, sPdfComb)) Then
                MsgBox "Error saving combined pdf:" & vbCrLf _
                    & vbCrLf & "[" & sPdfComb & "]" & vbCrLf _
                    & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
                GoTo Exit_Sub
            End If

            PdfSrc.Close
            Set PdfSrc = Nothing

        End With

'        sPdf = Dir(sPdf, vbArchive)
'    Loop While sPdf <> vbNullString
    Loop

    MsgBox "Pdf files combined successfully!", vbExclamation

Exit_Sub:
    PdfDst.Close

   End Sub

Ответ 3

Приведенный ниже код, полученный при переполнении стека, перечислит все подпапки в папке.

Sub FolderNames()
'Update 20141027
Application.ScreenUpdating = False
Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
'Application.Workbooks.Add
Set xWs = Application.ActiveSheet
Sheets("Sheet1").Cells.Clear
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 5).Value = Array("Path", "Dir", "Name", "Date Created",            "Date Last Modified")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.GetFolder(xPath)
getSubFolder folder1
xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535
xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
For Each SubFolder In prntfld.SubFolders
xRow = Range("A1").End(xlDown).Row + 1
Cells(xRow, 1).Resize(1, 5).Value = Array(SubFolder.Path, Left(SubFolder.Path,       InStrRev(SubFolder.Path, "\")), SubFolder.Name, SubFolder.DateCreated, SubFolder.DateLastModified)
Next SubFolder
For Each subfld In prntfld.SubFolders
getSubFolder subfld
Next subfld
End Sub

Этот код объединит все файлы PDF в подпапке и сохранит выходные данные в выбранной папке назначения.

Sub Merger()
Dim i As Integer
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")
Dim k As Integer
Dim st As String
Dim na As String
Dim dest As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the Destination folder"
.Show
End With
dest = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"


k = sh.Range("A1048576").End(xlUp).Row
For i = 3 To k
st = sh.Cells(i, 1).Value
na = sh.Cells(i, 3).Value
Call Main(st, na, dest)
Next

 MsgBox "The resulting files are created" & vbLf & p & DestFile, vbInformation, "Done"

End Sub

Sub Main(ByVal st As String, ByVal na As String, dest As String)

Dim DestFile As String
DestFile = "" & dest & na & ".pdf" ' <-- change TO Your Required Desitination

Dim MyPath As String, MyFiles As String
Dim a() As String, i As Long, f As String
Dim R As Range
Dim ws As Worksheet
Dim n As Long



 ' Choose the folder or just replace that part by: MyPath = Range("E3")
With Application.FileDialog(msoFileDialogFolderPicker)
     '.InitialFileName = "C:\Temp\"
    .AllowMultiSelect = True
    'If .Show = False Then Exit Sub
    MyPath = st
    DoEvents
End With

  ' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
ReDim a(1 To 2 ^ 14)

f = Dir(MyPath & "*")
While Len(f)
    If StrComp(f, DestFile, vbTextCompare) Then
        i = i + 1
        a(i) = f
        'a().Sort
    End If
    f = Dir()
Wend

'SORTING--------------------------------------------------------

Set ws = ThisWorkbook.Sheets("Sheet2")

' put the array values on the worksheet
Set R = ws.Range("A1").Resize(UBound(a) - LBound(a) + 1, 1)
R = Application.Transpose(a)

' sort the range
R.Sort key1:=R, order1:=xlAscending, MatchCase:=False

' load the worksheet values back into the array
For n = 1 To R.Range("A1048576").End(xlUp).Row
    a(n) = R(n, 1)
Next n

If i Then
    ReDim Preserve a(1 To i)
    MyFiles = Join(a, ",")
    Application.StatusBar = "Merging, please wait ..."
    Call MergePDFs(MyPath, MyFiles, DestFile)
    Application.StatusBar = False
Else
    MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If

End Sub

'ZVI: 2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X 'Требуется ссылка: VBE - Инструменты - Ссылки - Acrobat

Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String)
Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
a = Split(MyFiles, ",")
ReDim PartDocs(0 To UBound(a))

On Error GoTo exit_
If Len(Dir(DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
    ' Check PDF file presence
    If Dir(p & Trim(a(i))) = "" Then
        MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
        Exit For
    End If
    ' Open PDF document
    Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
    PartDocs(i).Open p & Trim(a(i))
    If i Then
        ' Merge PDF to PartDocs(0) document
        ni = PartDocs(i).GetNumPages()
        If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
            MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
        End If
        ' Calc the number of pages in the merged document
        n = n + ni
        ' Release the memory
        PartDocs(i).Close
        Set PartDocs(i) = Nothing
    Else
        ' Calc the number of pages in PartDocs(0) document
        n = PartDocs(0).GetNumPages()
    End If
Next

If i > UBound(a) Then
    ' Save the merged document to DestFile
    If Not PartDocs(0).Save(PDSaveFull, DestFile) Then
        MsgBox "Cannot save the resulting document" & vbLf & p & DestFile,    vbExclamation, "Canceled"
    End If
End If
 exit_:

' Inform about error/success
If Err Then
    MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
    'MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If

' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing

' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing

End Sub

Ответ 4

У меня нет точной оценки для вашей проблемы, однако у меня был подобный, а именно, что я хотел добавить поля в pdf от VBA.

Я могу сказать вам, что Adobe имеет JavaScript API, который вы можете контролировать через vba.

Вот ссылка на API https://www.adobe.com/devnet/acrobat/javascript.html

И это часть кода, который я использовал в VBA для управления полями в PDF файлах.

Set app = CreateObject("Acroexch.app")
app.Show
Set AVDoc = CreateObject("AcroExch.AVDoc")
Set AForm = CreateObject("AFormAut.App") 'from AFormAPI
AVDoc.Open(pathsdf, "")

Ex = "Put your JavaScript Code here"

AForm.Fields.ExecuteThisJavaScript Ex

Вероятно, вам стоит посмотреть на метод insertPages в API.

Все, что возможно, это использование сборки в ссылке с VBA на Acrobat. Тем не менее, я нашел его очень ограниченным, и я не работал с ним. Есть только несколько доступных объектов, вот несколько примеров:

Dim AcroApp As Acrobat.AcroApp
Dim objAcroAVDoc As New Acrobat.AcroAVDoc
Dim objAcroPDDoc As Acrobat.AcroPDDoc
Dim objAcroPDPage As Acrobat.AcroPDPage
Dim annot As Acrobat.AcroPDAnnot