|
Hallo habe folgendes Problem :
Ich möchte das sich beim abspeichern "speichern unter" gleichzeitig eine PDF erstellt wird , diese erstellte pdf soll sich dann mit einer anderen PDF deren Dateiname ähnlich ist zusammen fügen und speichern.Dabei sollte es so sein das die erstellte PDF aus Excel durch die zusammengefügte ersetzt wird . Ich bin jetzt soweit das die PDF erstellt wird die richtige 2. PDF gefunden wird , aber das diese dateien am Ende nicht zusammen gefügt sind.Ich würde mich über Hilfe sehr freuen.
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error GoTo ErrorHandler
Dim SavePath As String
Dim FileName As String
Dim NewFileName As String
Dim PDFPath As String
Dim ParentFolder As String
Dim PDFSubFolder As String
Dim IsometrienFolder As String
Dim ClosestPDFPath As String
Dim TempPDFPath As String
Dim Cmd As String
Dim TaskID As Double
Dim FolderDialog As FileDialog
Dim PDFtkPath As String
' Pfad zur PDFtk-Anwendung
PDFtkPath = "C:\Program Files (x86)\PDFtk\bin\PdftkXp.exe"
Debug.Print "PDFtkPath: " & PDFtkPath
If Dir(PDFtkPath) = "" Then
MsgBox "Fehler: PDFtk-Anwendung wurde nicht gefunden."
Exit Sub
End If
If SaveAsUI Then
NewFileName = InputBox("Bitte geben Sie den neuen Dateinamen ein:", "Dateiname ändern", Left(ThisWorkbook.name, InStrRev(ThisWorkbook.name, ".") - 1))
Debug.Print "NewFileName: " & NewFileName
If NewFileName <> "" Then
Set FolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
FolderDialog.Title = "Wählen Sie den Speicherort für die neue Datei"
If FolderDialog.Show = -1 Then
SavePath = FolderDialog.SelectedItems(1)
Debug.Print "SavePath: " & SavePath
Else
Exit Sub
End If
If Dir(SavePath, vbDirectory) = "" Then
MsgBox "Fehler: Der Pfad " & SavePath & " wurde nicht gefunden."
Exit Sub
End If
SavePath = SavePath & "\" & NewFileName & ".xlsm"
Debug.Print "Final SavePath: " & SavePath
Cancel = True
Application.EnableEvents = False
ThisWorkbook.SaveAs SavePath
Application.EnableEvents = True
FileName = NewFileName
Debug.Print "FileName: " & FileName
ParentFolder = Left(SavePath, InStrRev(SavePath, "\") - 1)
Debug.Print "ParentFolder: " & ParentFolder
PDFSubFolder = Replace(ParentFolder, "Protokolle\Excel", "Protokolle\PDF")
Debug.Print "PDFSubFolder: " & PDFSubFolder
CreateFolderIfNotExist PDFSubFolder
PDFPath = PDFSubFolder & "\" & FileName & ".pdf"
Debug.Print "PDFPath: " & PDFPath
ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFPath, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
If Not FileExists(PDFPath) Then
MsgBox "Fehler: Die PDF-Datei wurde nicht erstellt."
Exit Sub
End If
IsometrienFolder = Replace(ParentFolder, "Protokolle\Excel", "Isometrien")
Debug.Print "IsometrienFolder: " & IsometrienFolder
CreateFolderIfNotExist IsometrienFolder
Dim fso As Object, folder As Object, file As Object
Dim MinDistance As Long: MinDistance = -1
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(IsometrienFolder)
For Each file In folder.Files
If LCase(fso.GetExtensionName(file)) = "pdf" Then
Dim Distance As Long
Distance = LevenshteinDistance(FileName, fso.GetBaseName(file.name))
Debug.Print "Comparing with: " & file.name & ", Distance: " & Distance
If MinDistance = -1 Or Distance < MinDistance Then
MinDistance = Distance
ClosestPDFPath = file.Path
Debug.Print "ClosestPDFPath: " & ClosestPDFPath
End If
End If
Next file
TempPDFPath = PDFPath
Debug.Print "TempPDFPath: " & TempPDFPath
If Dir(PDFPath) = "" Or Dir(ClosestPDFPath) = "" Then
MsgBox "Fehler: PDFPath oder ClosestPDFPath existiert nicht."
Exit Sub
End If
' Überprüfen, ob die zusammengeführte Datei vorher existiert und ggf. löschen
If FileExists(TempPDFPath) Then
Kill TempPDFPath
End If
Cmd = "cmd /c """ & PDFtkPath & """ cat """ & PDFPath & """ """ & ClosestPDFPath & """ output """ & TempPDFPath & """"
Debug.Print "Cmd: " & Cmd
TaskID = Shell(Cmd, vbNormalFocus)
Debug.Print "TaskID: " & TaskID
Dim startTime As Single
startTime = Timer ' Aktuelle Zeit erhalten
Do
DoEvents
Sleep 100
If Timer - startTime > 10 Then ' Timeout nach 10 Sekunden
MsgBox "Fehler: Vorgang ist abgelaufen."
Exit Do
End If
Loop While TaskExists(TaskID)
If Not FileExists(TempPDFPath) Then
MsgBox "Fehler: Zusammengeführte PDF wurde nicht erstellt."
Exit Sub
End If
MsgBox "PDF erfolgreich erstellt und zusammengeführt: " & TempPDFPath
Else
MsgBox "Speichern wurde abgebrochen."
End If
End If
Exit Sub
ErrorHandler:
MsgBox "Fehler: " & Err.Number & " - " & Err.Description
Debug.Print "Fehler: " & Err.Number & " - " & Err.Description
End Sub
Private Sub CreateFolderIfNotExist(ByVal FolderPath As String)
Debug.Print "CreateFolderIfNotExist: " & FolderPath
If Dir(FolderPath, vbDirectory) = "" Then
MkDir FolderPath
End If
End Sub
Private Function FileExists(ByVal FilePath As String) As Boolean
Debug.Print "FileExists: " & FilePath
FileExists = Len(Dir(FilePath)) > 0
End Function
Private Function TaskExists(ByVal TaskID As Long) As Boolean
Debug.Print "TaskExists: " & TaskID
On Error Resume Next
TaskExists = Not IsEmpty(GetObject("winmgmts:").ExecQuery("SELECT * FROM Win32_Process WHERE ProcessId = " & TaskID).Count)
On Error GoTo 0
End Function
Private Function LevenshteinDistance(ByVal s1 As String, ByVal s2 As String) As Long
Dim i As Long, j As Long, n As Long, m As Long
Dim d() As Long
n = Len(s1)
m = Len(s2)
ReDim d(0 To n, 0 To m)
Debug.Print "LevenshteinDistance s1: " & s1 & ", s2: " & s2
For i = 0 To n: d(i, 0) = i: Next i
For j = 0 To m: d(0, j) = j: Next j
For i = 1 To n
For j = 1 To m
Dim cost As Long
cost = IIf(Mid(s1, i, 1) = Mid(s2, j, 1), 0, 1)
d(i, j) = Application.Min(Application.Min(d(i - 1, j) + 1, d(i, j - 1) + 1), d(i - 1, j - 1) + cost)
Next j
Next i
LevenshteinDistance = d(n, m)
Debug.Print "LevenshteinDistance result: " & d(n, m)
End Function
|