|
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
|