Als PDF speichern mit Namenergänzung
13.12.2020 11:56:47
Ulrich
ich habe eine Frage.
Mit folgendem Code speichere ich in einer Tabelle aufgelistete Exceldateien als eine PDF Datei.
Die pdf hat den Namen "Gesamt.pdf"
Ich hätte dort noch gerne eine Namenserweiterung mit dem Text aus Zelle M2, hinter "Gesamt_...".
Kann mir jemand helfen?
Gruß Ull
Option Explicit
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long
Public Sub CreatePDF()
Dim lngRow As Long, lngLastRow As Long
Dim astrFiles() As String, strFolderPath As String, strFilePath As String
Dim objWorkbook As Workbook
strFolderPath = ThisWorkbook.Path & "\Temp\"
If MakeSureDirectoryPathExists(strFolderPath) = 1 Then
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
If Dir$(PathName:=strFolderPath & "*.*") vbNullString Then _
Call Kill(PathName:=strFolderPath & "*.*")
lngLastRow = Cells(Rows.Count, 3).End(xlUp).Row
ReDim astrFiles(7 To lngLastRow)
For lngRow = 7 To lngLastRow
Debug.Print Cells(lngRow, 3).Hyperlinks(1).Address
Set objWorkbook = GetObject(PathName:=Cells(lngRow, 3).Hyperlinks(1).Address)
strFilePath = strFolderPath & CStr(lngRow) & ".pdf"
Call objWorkbook.Worksheets("Protokoll").ExportAsFixedFormat(Type:=xlTypePDF, _
Filename:=strFilePath, Quality:=xlQualityStandard, IncludeDocProperties:=False, _
_
IgnorePrintAreas:=False, OpenAfterPublish:=False)
astrFiles(lngRow) = strFilePath
Call objWorkbook.Close(SaveChanges:=False)
Next
Call Shell(PathName:="C:\Program Files (x86)\PDFtk\bin\pdftk.exe " & Join(astrFiles) & _
_
" cat output " & ThisWorkbook.Path & "\Gesamt.pdf", WindowStyle:=vbHide)
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
Else
Call MsgBox("Fehler beim erstellen des temporären Ordners.", vbCritical, " _
Dateisystemfehler")
End If
End Sub