2k Aufrufe
Gefragt in Tabellenkalkulation von marc1984 Einsteiger_in (51 Punkte)

Guten Morgen zusammen,

ist es möglich diesen Code so anzupassen, dass ein gesamter Inhalt aus einem Ordner an PDFs zusammengeführt wird?

Option Explicit
Sub multidoc()
  Dim fso As Object, WshShell As Object
  Dim strOrdner As String, i As Long
  Dim strMulti As String, strCommand As String, strGS As String
  Set fso = CreateObject("Scripting.FileSystemObject")
 'Pfad zu gswin32c.exe anpassen
  strGS = "C:\Programme\Textbearbeitung\Ghostscript\gs8.53\bin\gswin32c.exe"
 'Ausgabeordner anpassen
  strOrdner = ThisWorkbook.Worksheets("JUBILARE_DBASE").Range("J3") & Format(Date, "YYYY-MM-DD") & "\"
  With JUBILARE_DBASE   'anpassen
   'Spalte A : Dateinamen mit komplettem Pfad
   'Spalte B : Dateinamen mit komplettem Pfad
    For i = 2 To .UsedRange.Rows.Count
      If fso.FileExists(.Cells(i, 1).Value) And fso.FileExists(.Cells(i, 2).Value) Then
        strMulti = " " & Chr(34) & .Cells(i, 1).Value & Chr(34) & " " & Chr(34) & .Cells(i, 2).Value & Chr(34)
        strOrdner = fso.getfolder(strOrdner).ShortPath
        strGS = fso.GetFile(strGS).ShortPath
        strCommand = strGS & " -q -dSAFER -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=" & Chr(34)
        strCommand = strCommand & strOrdner & "\"
       'Name der Ausgabedatei = Name der Datei in der Spalte A
        strCommand = strCommand & fso.GetFile(.Cells(i, 1).Value).Name & Chr(34) & strMulti
        Debug.Print strCommand
        Set WshShell = CreateObject("WScript.Shell")
        WshShell.Run strCommand, 0, True
        Set WshShell = Nothing
      End If
    Next
  End With
  Set fso = Nothing
  MsgBox "Fertig"
End Sub

 Der Inhalt befindet sich im Pfad des strOrdner  - wo auch die zusammengeführte Datei hinsollte.

Die einzelnen Dateien werden mittels folgendem Code abgelegt:

Aus Tabellenblatt:

Private Sub CommandButton5_Click()
Dim lngLletzte As Long
Dim lngZeile As Long
Dim strPfad As String

strPfad = ThisWorkbook.Worksheets("JUBILARE_DBASE").Range("J3")

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If MsgBox("Bist du sicher, dass du mit dem Export des Serienbriefs beginnen willst?", vbExclamation + vbYesNo) = vbYes Then

If Dir(strPfad & Format(Date, "YYYY-MM-DD"), vbDirectory) = "" Then
MkDir strPfad & Format(Date, "YYYY-MM-DD")
End If


With ThisWorkbook.Worksheets("JUBILARE_DBASE")
  'letzte beschriebene Zeile ermittlen
  lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
  
  'alle Zeilen durchlaufen
  For lngZeile = 6 To lngLetzte
   'Prüfen ob Gewerbliche oder Angestellte sowie und nur für ausgewählten Monat ausführen!
    If .Cells(lngZeile, 14).Value = .Range("C3") Then Call PDFSerienSpeichern(lngZeile)

  Next lngZeile
MsgBox "Die Urkunden wurden gespeichert!"
End With

Else
MsgBox "Du hast das Makro abgebrochen!"
End If

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Im Modul:

 

Sub PDFSerienSpeichern(lngZeile As Long)
Dim strPfad As String
Dim Dateiname As String
Dim OpenPDF As String
Dim Entry As String

If Sheets("JUBILARE_DBASE").Cells(lngZeile, 6).Value <> "" Then Entry = Sheets("JUBILARE_DBASE").Cells(lngZeile, 6).Value Else Entry = Sheets("JUBILARE_DBASE").Cells(lngZeile, 7).Value

Sheets("JUBILARE_Urkunde").Range("B16").Value = Sheets("JUBILARE_DBASE").Cells(lngZeile, 2).Value & " " & Sheets("JUBILARE_DBASE").Cells(lngZeile, 3).Value
Sheets("JUBILARE_Urkunde").Range("B19").Value = Entry
Sheets("JUBILARE_Urkunde").Range("A15").Value = Sheets("JUBILARE_DBASE").Cells(lngZeile, 15).Value


strPfad = ThisWorkbook.Worksheets("JUBILARE_DBASE").Range("J3") & Format(Date, "YYYY-MM-DD") & "\"
Dateiname = ThisWorkbook.Worksheets("JUBILARE_Urkunde").Range("B19").Value & " - JUBILAR - " & ThisWorkbook.Worksheets("JUBILARE_Urkunde").Range("B16").Value
    ChDir strPfad
    ThisWorkbook.Worksheets("JUBILARE_Urkunde").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        strPfad & Dateiname & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True _
        , IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

Vielen Dank für Eure Hilfen.


VG 

4 Antworten

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

Hallo,

kopiere das folgende Makro in ein allgemeines Modul:

Sub PDF_Merge()
Dim strPfad As String
Dim strGS As String
Dim strPDF As String
Dim strDatname As String
Dim strCommand As String
Dim t As Variant

'Pfad für Ghostscript - ggf. anpassen
strGS = "C:\Programme\Textbearbeitung\Ghostscript\gs8.53\bin\gswin32c.exe"

'Verzeichnis auswählen, in dem die PDFs stehen, die zusammengefügt werden sollen
strPfad = ThisWorkbook.Worksheets("JUBILARE_DBASE").Range("J3") & Format(Date, "YYYY-MM-DD") & "\"
'PDF-Dateien aus Verzeichnis einlesen
strDatname = Dir(strPfad & "*.pdf")

'Schleife zum einlesen aller entsprechenden Dateien
Do While Len(strDatname)

   'Dateiname eintragen:
   'Prüfen, ob Leerzeichen im Dateinamen existiert
   If InStr(strDatname, " ") Then
     'falls ja, muss der Dateiname in Anführungszeichen gesetzt werden
     strPDF = strPDF & " """ & strPfad & strDatname & """"
    Else
     'falls nein, reicht die einfache Übername des eingelesenen Namens
     strPDF = strPDF & " " & strPfad & strDatname
   End If

   strDatname = Dir

Loop

'für Ghostscript den Befehl erstellen
strCommand = strGS & " -dNOPAUSE -sDEVICE=pdfwrite -sOutputFile=" & strPfad & "Merged.pdf -dBATCH" & strPDF

'Ghostscript-Befehl ausführen
t = Shell(strCommand, 0)

'Abschlussmeldung
MsgBox "Alle Dateien im ausgewählten Verzeichnis wurden zusammengefügt", 48, "Zusammenfügen beendet"

End Sub

Der Name der zusammengefügten Datei lautet "Merge.pdf". Die PDF-Dateien werden in der Reihenfolge, in der sie eingelesen werden zusammengefügt. Beachte bitte, dass es nach der Abschlussmeldung etwas dauern kann, bis die PDF-Datei erstellt und in das Verzeichnis geschrieben wird.

Sollte es bereits eine PDF-Datei mit dem Namen Merged.pdf geben, wird diese ohne Rückfrage überschrieben.

Gruß

M.O.

0 Punkte
Beantwortet von marc1984 Einsteiger_in (51 Punkte)

Hallo M.O.,

ich hoffe du entschuldigst meine späte Antwort. Ich wurde in der Vergangenheit immer regulär informiert. Nun ist es anscheinend im Junk-Mail gelandet :)

Vielen  lieben Dank für deinen Code. Ich habe diesen getestet, aber bei mir kommt immer nur die letzte Meldung. Wenn ich nur den Pfad öffne, erhalte ich eine cmd Meldung, diese startet aber mit dem Code oben nicht. 

Ich habe lediglich den Pfad angepasst:

Sub PDF_Merge()
Dim strPfad As String
Dim strGS As String
Dim strPDF As String
Dim strDatname As String
Dim strCommand As String
Dim t As Variant

'Pfad für Ghostscript - ggf. anpassen
strGS = "C:\Program Files\gs\gs9.54.0\bin\gswin64c.exe"

'Verzeichnis auswählen, in dem die PDFs stehen, die zusammengefügt werden sollen
strPfad = ThisWorkbook.Worksheets("JUBILARE_DBASE").Range("J3") & Format(Date, "YYYY-MM-DD") & "\"
'PDF-Dateien aus Verzeichnis einlesen
strDatname = Dir(strPfad & "*.pdf")

'Schleife zum einlesen aller entsprechenden Dateien
Do While Len(strDatname)

   'Dateiname eintragen:
   'Prüfen, ob Leerzeichen im Dateinamen existiert
   If InStr(strDatname, " ") Then
     'falls ja, muss der Dateiname in Anführungszeichen gesetzt werden
     strPDF = strPDF & " """ & strPfad & strDatname & """"
    Else
     'falls nein, reicht die einfache Übername des eingelesenen Namens
     strPDF = strPDF & " " & strPfad & strDatname
   End If

   strDatname = Dir

Loop

'für Ghostscript den Befehl erstellen
strCommand = strGS & " -dNOPAUSE -sDEVICE=pdfwrite -sOutputFile=" & strPfad & "Merged.pdf -dBATCH" & strPDF

'Ghostscript-Befehl ausführen
t = Shell(strCommand, 0)

'Abschlussmeldung
MsgBox "Alle Dateien im ausgewählten Verzeichnis wurden zusammengefügt", 48, "Zusammenfügen beendet"

End Sub

Ich habe gesehen, dass es eine andere Version ist. Kann es daran liegen?

Lieben Dank und ein schönes Wochenende

Marc 

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Marc,

ob es an der Version liegt, müsste ich mal ausprobieren. Komme aber erst am Wochenende dazu das Makro mit der neuen Ghostscript-Version zu testen.

Ich würde auch mal prüfen, ob die Pfade richtig sind etc.

Gruß

M.O.
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

Hallo,

ich habe das jetzt mal mit der neuesten Ghostscript-Version probiert und dort funktioniert das Makro ebenfalls.

Ich habe die Excel-Datei allerdings in das Verzeichnis mit den PDFs, die zusammengeführt werden sollen, gespeichert und die Pfad-Angabe entsprechend geändert.

'Verzeichnis auswählen, in dem die PDFs stehen, die zusammengefügt werden sollen
strPfad = ThisWorkbook.Path & "\"

Bei mir sieht der Pfad für Ghostscript z.B. so aus:

'Pfad für Ghostscript - ggf. anpassen
strGS = "C:\Program Files (x86)\gs\gs9.54.0\bin\gswin32c.exe"

Also überprüfe noch einmal die Pfad-Angaben oder teste einfach mal die Version mit dem Abspeichern im betreffenden Verzeichnis, um zu prüfen, ob es überhaupt funktioniert.

Gruß

M.O.

...