ich habe folgendes Problem.
Um ein Kostenantragsformular zu erstellen möchte ich verschiedene pdf Dateien zusammenführen.
Die Antragsseite wird in Excel erstellt. Anschließend sollen die einzelnen Angebote mit dem Antrag zusammengeführt werden.
Die Angebote hole ich mir über den Dateipfad in mein Excel. Hier sollen sie ausgelesen und über pdftk zusammengestellt und als Mail verschickt werden.
Jetzt klappt aber leider das zusammenführen nicht richtig. Ich bekomme immer nur die Antragsdatei ohne Anhang ausgegeben.
Hier mein Code:
Option Explicit
Sub drucken()
' Antragsnummer +1
Tabelle1.Range("D12") = Tabelle1.Range("D12") + 1
' Dokument drucken
'Tabelle1.Range("B2:J39").PrintOut
'Als Pdf speichern
Tabelle1.Range("B2:J39").ExportAsFixedFormat xlTypePDF, Filename:="P:\Einkauf\Kostenantragsformulare\Kostenantragsformular HL\Kostenantragsformular HL" & Cells(12, 4) & ".pdf", Openafterpublish:=False
Call DateiZusammenführen
'Dokument leeren
Tabelle1.Range("C17:J30") = ""
End Sub
Sub DateiZusammenführen()
Const Kostenstelle As String = "HL"
Const Quellordner As String = "P:\Einkauf\Kostenantragsformulare\Kostenantragsformular " & Kostenstelle & "\"
Dim Zieldatei As String
Dim PfadGesamt As String
Dim PfadAngebot() As String
Dim i As Integer
Dim a As Integer
Dim objOutlook As Object, objMail As Object
Dim Antrag As String
Antrag = Quellordner & Zieldatei
Zieldatei = "Kostenantragsformular " & Kostenstelle & Cells(12, 4) & ".pdf"
'Anzahl der Pfade speichern
For a = 1 To Cells(Rows.Count, 11).End(xlUp).Row - 17
Next a
'Anzahl Pfade
ReDim PfadAngebot(a - 1)
'Anzahl Pfade Speichern
For i = 0 To UBound(PfadAngebot)
If Cells(i + 17, 11) = "" Then
GoTo Weiterspringen
Else
PfadAngebot(i) = Cells(i + 17, 11).Value
End If
'Pfad(i).PrintOut
Next i
Weiterspringen:
'Pfade Verbinden
PfadGesamt = join(PfadAngebot, " ") 'Antrag & " " &
' Range("A1") = PfadGesamt
If PfadGesamt = " " Then
Call MsgBox("Keine Dateien gefunden.", vbExclamation, "Hinweis")
Else
'Dateien zusammenführen
'PDFtk
Call Shell(PathName:="C:\Program Files (x86)\PDFtk\bin\pdftk.exe " & _
PfadGesamt & "cat output" & Chr$(34) & Quellordner & Zieldatei & Chr$(34), WindowStyle:=vbNormalFocus)
Call Application.Wait(Time:=Now + TimeSerial(0, 0, 3))
'An Email Anhängen
Set objOutlook = CreateObject(Class:="Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "info@info.de"
.cc = ""
.Subject = "Kostenantrag " & Kostenstelle & Cells(12, 4)
.Body = "Hallo," & vbLf & vbLf & "im Anhang der Kostenantrag " & Kostenstelle & Cells(12, 4) & "." & _
vbLf & vbLf & "Gruß" & vbLf & Cells(35, 4)
Call .Attachments.Add(Quellordner & Zieldatei)
Call .Display
End With
Set objMail = Nothing
Set objOutlook = Nothing
End If
End Sub
Hier auch die Datei:https://www.herber.de/bbs/user/146041.xlsm
Ich vermute mal, dass im Shell der Fehler liegt. Komm aber grad nicht drauf.
Ich wäre sehr über eure Hilfe dankbar! Wenn ihr noch mehr Infos braucht, immer gerne melden.
Viele Grüße
Dominik