Thema Datum  Von Nutzer Rating
Antwort
Rot PDF combine
13.01.2023 23:57:17 Christian Winkler
NotSolved

Ansicht des Beitrags:
Von:
Christian Winkler
Datum:
13.01.2023 23:57:17
Views:
54
Rating: Antwort:
  Ja
Thema:
PDF combine

Hallo zusammen,

ich bin auf der Suche nach ein wenig ergänzender Hilfe beim Kombinieren von PDFs. Meine Kenntisse sind da nicht ausreichend.

In einem Ordner liegen hunderte von subfoldern, in denen einzelne Pdfs liegen. Jeweils das erste pdf in den Subfoldern soll nicht verarbeitet werden. Alle andern in den jeweiligen subfoldern combinert werden und ein zusätzliches merged pdf in den jeweiligen Unterordnern abgelegt werden. 

Der Inhalt einer solcher Ordner sieht exemplarsich so aus:

 

01-Nov-2022 08 20 249043.pdf

249043-924481-027ba84cae719d803e566399e58d1f9c.pdf

249043-924481-f6935271f6d1e6ffa8014faa0f33cb54.pdf

249043-924483-541e168c789a4959110d15b26837bee2.pdf

249043-924483-cf209fd1eb3f1f8b5e6eeb35c0354ea4.pdf

 

...und sollte möglichst zu ....

01-Nov-2022 08 20 249043.pdf

249043-924481-027ba84cae719d803e566399e58d1f9c.pdf

249043-924481-f6935271f6d1e6ffa8014faa0f33cb54.pdf

249043-924483-541e168c789a4959110d15b26837bee2.pdf

249043-924483-cf209fd1eb3f1f8b5e6eeb35c0354ea4.pdf

merged.pdf

...werden.

 

 

Im Netz hab ich auch einen Code gefunden, der zwar funktioniert, aber halt meinen Bedürfnissen angepasst werden müsste. Was ich leider nicht hinkriege.

 

Danke euch!

 

VG

 

Sub Main()
    Dim lngNumber As String

    Const DestFile As String = "MergedFile.pdf" ' <-- change to suit
 

    Dim MyPath As String, MyFiles As String

    Dim a() As String, i As Long, f As String
 

     ' Choose the folder or just replace that part by: MyPath = Range("E3")

    With Application.FileDialog(msoFileDialogFolderPicker)

         '.InitialFileName = "C:\Temp\"

        .AllowMultiSelect = False

        If .Show = False Then Exit Sub

        MyPath = .SelectedItems(1)

        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 & "*.pdf")

    While Len(f)

        If StrComp(f, DestFile, vbTextCompare) Then

            i = i + 1

            a(i) = f

        End If

        f = Dir()

    Wend
 

     ' Merge PDFs

    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
 

Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")

     ' 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

     ' Reference required: VBE - Tools - References - Acrobat
 

    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(p & 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, p & 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


 

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot PDF combine
13.01.2023 23:57:17 Christian Winkler
NotSolved