Sub
SaveActiveWorkbookAsPDF(control
As
IRibbonControl)
Dim
pdfFileName
As
String
Dim
pdfFilePath
As
String
Dim
pdfFullName
As
String
Dim
fileExists
As
Boolean
Dim
userResponse
As
VbMsgBoxResult
Dim
workbookName
As
String
Dim
activeWorkbook
As
Workbook
Set
activeWorkbook = Application.activeWorkbook
pdfFilePath = activeWorkbook.Path
workbookName = activeWorkbook.Name
pdfFileName = Left(workbookName, InStrRev(workbookName,
"."
) - 1)
pdfFullName = pdfFilePath &
"\" & pdfFileName & "
.pdf"
fileExists = Dir(pdfFullName) <>
""
If
fileExists
Then
userResponse = MsgBox(
"Die PDF-Datei '"
& pdfFullName &
"' ist bereits vorhanden. Sie wird überschrieben. Möchten Sie fortfahren?"
, vbYesNo + vbExclamation,
"Datei überschreiben?"
)
If
userResponse = vbNo
Then
Exit
Sub
End
If
End
If
If
IsFileOpen(pdfFullName)
Then
MsgBox
"Die PDF-Datei '"
& pdfFullName &
"' ist bereits geöffnet."
, vbExclamation
Exit
Sub
End
If
On
Error
Resume
Next
activeWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFullName, Quality:=xlQualityStandard
If
Err.Number <> 0
Then
MsgBox
"Fehler beim Exportieren der PDF-Datei. Bitte überprüfen Sie, ob die Datei geöffnet ist oder ob Sie die richtigen Berechtigungen haben."
, vbCritical
Err.Clear
Exit
Sub
End
If
On
Error
GoTo
0
Shell
"explorer.exe "
""
& pdfFullName &
""
, vbNormalFocus
End
Sub
Function
IsFileOpen(filePath
As
String
)
As
Boolean
On
Error
Resume
Next
Dim
fileNum
As
Integer
If
Dir(filePath) =
""
Then
Debug.Print
"Datei existiert nicht: "
& filePath
IsFileOpen =
False
Exit
Function
End
If
fileNum = FreeFile
Open filePath
For
Input Lock Read
As
#fileNum
Close #fileNum
IsFileOpen = (Err.Number <> 0)
Err.Clear
On
Error
GoTo
0
End
Function