Zusätzlich beim speichern ein Tabellenblatt als PDF ablegen...

Frage: Ein bestimmtes Tabellenblatt soll zusätzlich zum speichern der Excel Datei noch als PDF gespeichert werden. Eine vorhandene PDF-Datei soll ohne Nachfrage überschrieben werden. Wie geht das?

One particular worksheet is in addition to save the Excel file be saved as a PDF. An existing PDF file will be overwritten without prompting. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Zusätzlich beim speichern ein Tabellenblatt als PDF ablegen...[ZIP 80 KB]

Code gehört in "DieseArbeitsmappe" / Code belongs in "ThisWorkbook":

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long
' Pfad für die PDF-Datei MIT abschliessendem Backslash anpassen!!!!
Const strPDFPath As String = "C:\Temp\"
'--------------------------------------------------------------------------
' Module    : ThisWorkbook
' Procedure : Workbook_BeforeSave
' Author    : Case (Ralf Stolzenburg)
' Date      : 28.11.2013
' Purpose   : Always save as PDF in particular folder...
'--------------------------------------------------------------------------
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Name des Tabellenblattes anpassen!!!!!
    With ThisWorkbook.Worksheets("Sheet1")
        ' Prüfen ob Ordner vorhanden ist
        If PathFileExists(strPDFPath) <> 0 Then
            ' PDF-Datei im vorgegebenen Pfad erstellen - NUR ein Tabellenblatt
            ' Dateiname ist wie Exceldateiname mit Datum und Uhrzeit
            '.ExportAsFixedFormat 0, strPDFPath & fncEXT(.Parent.Name) & _
                Format(Now, "_YYYY_MM_DD_hh_mm_ss")
            ' Dateiname ist wie Exceldateiname VORHANDENE DATEI WIRD ERSETZT
            .ExportAsFixedFormat 0, strPDFPath & fncEXT(.Parent.Name)
            ' PDF-Datei im vorgegebenen Pfad erstellen - NUR ein Tabellenblatt
            ' Dateiname ist wie Worksheetname mit Datum und Uhrzeit
            '.ExportAsFixedFormat 0, strPDFPath & .Name & _
                Format(Now, "_YYYY_MM_DD_hh_mm_ss")
            ' Dateiname ist wie Worksheetname VORHANDENE DATEI WIRD ERSETZT
            '.ExportAsFixedFormat 0, strPDFPath & .Name
        Else
            ' Pfad anlegen
            MakeSureDirectoryPathExists (strPDFPath)
            ' PDF-Datei im vorgegebenen Pfad erstellen
            .ExportAsFixedFormat 0, strPDFPath & fncEXT(.Parent.Name) & _
                Format(Now, "_YYYY_MM_DD_hh_mm_ss")
        End If
        Application.Run ("Module1.Main")
    End With
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
' Name und Extension trennen
Function fncEXT(ByVal strName As String) As String
    fncEXT = Mid(strName, 1, InStr(strName, ".") - 1)
End Function

Code gehört in ein Modul (Modul1) / Code belongs in a module (Module1):

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 28.11.2013
' Purpose   : Ausblenden Druckvorschaulinien. Hide print preview lines...
'--------------------------------------------------------------------------
Private Sub Main()
    Dim wksSheet As Worksheet
    For Each wksSheet In ThisWorkbook.Worksheets
        ' Die Druckvorschaulinien ausblenden
        wksSheet.DisplayAutomaticPageBreaks = False
    Next wksSheet
End Sub

Kommentare

  1. Cooler Tipp.
    Aber warum verwendest Du
    Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
    Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long

    statt Dir() mit den Attributen 0 oder 16?

    Grüße AF-Network

    AntwortenLöschen

Kommentar veröffentlichen

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...