AW: Makro um PDF-Dateien in einem Ordner zu mergen
11.01.2019 13:21:01
Malte
Hallo onur,
vielen Dank für deinen Link! Der Code funktioniert prima!
Ich habe ihn jetzt auf meine Situation angepasst.
Momentan werden die PDF-Dateien, die zusammengesetzt werden sollen noch als Konstante definiert.
Könnte jemand den Code so anpassen, dass alle PDF Dateien in einem Ordner zusammengefasst werden?
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
'Pfade -> bei Bedarf anpassen
Const str_pfad = "C:\Users\Anwender\Desktop\PDF\PDF" 'Pfad des Ordners mit den _
Ausgangsdateien
Const str_Ausgangsdateien = "1.pdf,2.pdf,3.pdf" 'Dateinamen der Dateien, die _
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 & "\"
a = Split(str_Ausgangsdateien, ",")
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