PDF zusammenfügen
26.05.2020 09:51:22
Julian
ich versuche gerade, mithilfe von VBA und Adobe Acrobat alle PDF-Dateien innerhalb eines Ordners zu einer Datei zusammen zu fügen. Da ich noch ziemlicher Anfänger bin, war ich sehr froh, dass mir dieser alte Forumseintrag einen Anknüpfungspunkt gegeben hat:
https://www.herber.de/forum/archiv/1664to1668/1667467_Makro_um_PDFDateien_in_einem_Ordner_zu_mergen.html
Allerdings bekomme ich immer den Fehler, dass der Dateipfad des Betreffenden Ordners, der immer als Nachname, Vorname benannt ist, um eine Wiederholung des Nachnamens verlängert wird, wodurch das Makro natürlich nicht auf den richtigen Ordner zugreifan kann ("C:\...\Nachname, Vorname\ Überzählige Wiederholung Nachname"). Mit trial and error komme ich gerade einfach nicht weiter. Weiß jemand, vielleicht, wo hier der Fehler im Skript liegt bzw. wie es angepasst werden kann?
Es gab noch einen Änderungsvorschlag in dem letzten Post des alten Thread, von dem ich jedoch nicht weiß, wie ich ihn in das Skript einfügen kann. Da er auch den Dateipfad betrifft könnte das Problem vielleicht so auch grundsätzlich umgangen werden.
Gibt es sonst vielleicht einen anderen Ansatz, den ich nicht sehr? Schon einmal vielen Dank für eure Hilfe.
Sub MergePDFs()
'Verweis zu Acrobat muss zuerst aktiviert werden!
'VBA-Editor ->Extras - Verweise - Acrobat
'Variablen deklarieren
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
Dim str_Ausgangsdateien As String, strDatei As String
'Pfade -> bei Bedarf anpassen
Const str_pfad = "C:\Users\Anwender\Desktop\PDF\Nachname, Vorname\Wiederholung Nachname" _
_
'Pfad des Ordners mit den zusammengeführt werden sollen
Const str_Ergebnisdatei = "PDFneu.pdf" 'Dateiname der neuen Datei, die _
_
ausgegeben wird
'Überprüfen ob str_Pfad mit einem - \ - abschließt
If Right(str_pfad, 1) = "\" Then p = str_pfad Else p = str_pfad & "\"
'Ausgangsdateien zusammenstellen
strDatei = Dir(p & "*pdf")
Do While Len(strDatei) > 0
str_Ausgangsdateien = str_Ausgangsdateien & "," & strDatei
strDatei = Dir() ' nächste Datei
Loop
If str_Ausgangsdateien = "" Then
MsgBox "Keine Dateien gefunden"
Exit Sub
End If
a = Split(Mid(str_Ausgangsdateien, 2), ",") 'erstes Komma abschneiden
Redim PartDocs(0 To Ubound(a))
On Error GoTo ende
If Len(Dir(p & str_Ergebnisdatei)) Then Kill p & str_Ergebnisdatei
For i = 0 To UBound(a)
'Überprüfen ob die Datei vorhanden ist
If Dir(p & Trim(a(i))) = "" Then
MsgBox "Datei wurde nicht gefunden!" & vbLf & p & a(i), vbExclamation, "Abgebrochen"
Exit For
End If
'PDF-Datei öffnen
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & Trim(a(i))
If i Then
'PDF zu PartDocs(0) hinzufügen
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Die Seiten aus der folgenden Dateie konnten nicht eingefügt werden:" & vbLf & p & a(i), _
_
_
vbExclamation, "Abgebrochen"
End If
'Seitenzahl im neuen Dokument berechnen
n = n + ni
'Speicher leeren
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
'Seitenzahl in temporärer Datei - PartDocs(0) - ermitteln
n = PartDocs(0).GetNumPages()
End If
Next
If i > UBound(a) Then
'Die neue Datei im angegebenen Pfad speichern
If Not PartDocs(0).Save(PDSaveFull, p & str_Ergebnisdatei) Then
MsgBox "Konnte die neue zusammengesetzte Datei nicht speichern" & vbLf & p & str_Ergebnisdatei, _
_
_
vbExclamation, "Abgebrochen"
End If
End If
ende:
'Fehler/Erfolg per Messagebox melden
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "Die zusammengesetzte Datei wurde erstellt:" & vbLf & p & str_Ergebnisdatei, _
vbInformation, "Fertig"
End If
'Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing
'Acrobat Applikation schließen
AcroApp.Exit
Set AcroApp = Nothing
End Sub