Eine Tabelle als PDF exportieren

    From The Document Foundation Wiki
    < Macros‎ | Calc
    This page is a translated version of the page Macros/Calc/016 and the translation is 100% complete.


    Beschreibung

    Dieses Makro exportiert ein Calc Tabellenblat als PDF. Das kann auch über Datei ▸ Als PDF exportieren... und über "Auswahl/ausgewählte Blätter" erledigt werden. Trotzdem kann es nötig werden, diesen Vorgang über ein Makro zu automatisieren.

    Diese Lösung ist Betriebssystem unabhängig.

    Alle Druckbereiche werden gelöscht, dann wird der markierte Bereich des Blattes als Druckbereich definiert und dann als PDF exportiert.

    Das Main Unterprogramm wird gestartet und der Blattname in den Anführungszeichen angegeben.

    Damit ist das Makro betriebsbereit. Das Makro wird aus einer einfachen Calc-Datei gestartet, so wie unten angefügt.

    Code

    In LibreOffice Basic:

    ' Copyright (c) 2011 Frieder Delor, Mailto: Einfach hier im Forum anschreiben :-)
    ' The function GetPath() is originally from:  Copyright (c) 2011 Volker Lenhardt
    ' This program is free software you can redistribute it and/or modify it under
    ' the terms of the GNU General Public License as published by the Free Software
    ' Foundation; either version 2 of the License, or (at your option) any later
    ' version.
    
    ' This program is distributed in the hope that it will be useful, but WITHOUT
    ' ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
    ' FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
    
    ' You should have received a copy of the GNU General Public License along with
    ' this program; if not, write to the Free Software Foundation, Inc., 59 Temple
    ' Place, Suite 330, Boston, MA 02111-1307 USA
    
    
    
    'Option Explicit
    
    ' Weitere Dims sind immer noch nötig, so dass (^) Option explizit funktioniert...
    ' Andererseits arbeitet das Makro.
    
    
    Sub Main()
    
        ExportToPDF ("Tabelle1")  ' put Calc sheet name here
    
    End Sub ' Main
    
    
    Sub ExportToPDF (sSheetName As String)
    
        MsgBox "Zielpfad für das PDF auswählen"
        sPath = GetPath
    
        If sPath = "" Then
            MsgBox "kein gültiger Dateipfad", 16, "Fehler"
            GoTo Section1
        End If
    
        Section0:
        sStandard = "PDF_Export_" & sSheetName  & "_" & Format(Now,"yyyy-mm-dd") & "_" & Format(Now, "hhmm")
    
        sName=InputBox ("Bitte einen Namen " & Chr(10) & _
                    "für die PDF-Datei angeben." , "PDF-Datei", sStandard )
        If sName="" Then
            nVar = MsgBox ("Sie haben keinen Namen angegeben. " & Chr(10) & _
                        "Bitte geben Sie einen Namen an. " & Chr(10) & _
                        "Wenn Sie auf ""Abbrechen"" klicken, " & Chr(10) & _
                        "stoppt der Export.", 1, "Fehler")
            If nVar = 1 Then   ' OK wurde geklickt
                GoTo Section0
            Else
                GoTo Section1
            End If
        End If
    
        sFileName= sName & ".pdf"
        If FileExists(sPath & sFileName) Then
            nVar=MsgBox ("Die Datei existiert bereits. " & Chr(10) & _
                        "Soll die Datei ersetzt werden? " & Chr(10) & _
                        Chr(10) & _
                        "Wenn Sie auf ""Abbrechen"" klicken, " & Chr(10) & _
                        "stoppt der Export." & Chr(10) & _
                        "Wenn Sie auf ""Nein"" klicken," & Chr(10) & _
                        "können Sie einen anderen Namen angeben.", 3, "Fehler")
            Select Case nVar
                Case 2        ' Abbrechen wurde gewählt
                    GoTo Section1
                Case 6        ' Ja wurde gewählt
                Case 7        ' Nein wurde gewählt
                    GoTo Section0
            End Select
        End If
    
        ThisComponent.addActionLock
        ThisComponent.LockControllers
        oDoc = ThisComponent
        oSheets = oDoc.Sheets
        oSheet1 = oDoc.Sheets.getByName(sSheetName)
        Delete_PrintAreas
    
        For n = 0 To oSheets.getCount - 1
            oSheet=oDoc.Sheets(n)
            If oSheet.Name= sSheetName Then
                lEndCol= GetLastUsedColumn(oSheet1)
                lEndRow=GetLastUsedRow(oSheet1)
                Set_PrintAreas (n ,0 ,0 ,lEndCol ,lEndRow)
            End If
        Next
    
        export_pdf(sPath & sFileName)
        Delete_PrintAreas
        MsgBox "Das PDF wurde erfolgreich erstellt." , 0, "ExportToPDF()"
    
        Section1:
            ThisComponent.UnlockControllers
            ThisComponent.removeActionLock
    
    End Sub ' ExportToPDF()
    
    
    Sub Delete_PrintAreas()
        '''Alle Druckbereiche werden gelöscht.'''
    
        oDoc = ThisComponent
        oSheet = oDoc.Sheets(0)
        For n =0 To oDoc.Sheets.getCount - 1
            oDoc.Sheets(n).setPrintAreas(Array ())
        Next
        
    End Sub ' Delete_PrintAreas()
    
    
    Sub Set_PrintAreas (nSheet As Integer, lStartCol As Long, lStartRow As Long, lEndCol As Long, lEndRow As Long)
        '''Der Druckbereich wird definiert.'''
    
        Dim CellRangeAddress As New com.sun.star.table.CellRangeAddress
        oDoc = ThisComponent
        oSheet = oDoc.Sheets(nSheet)
        CellRangeAddress.Sheet = nSheet
        CellRangeAddress.StartColumn = lStartCol
        CellRangeAddress.StartRow = lStartRow
        CellRangeAddress.EndColumn = lEndCol
        CellRangeAddress.EndRow = lEndRow
        aPrintAreas() = Array (CellRangeAddress)
        oSheet.setPrintAreas(aPrintAreas())
        
    End Sub ' Set_PrintAreas
    
    
    Function GetLastUsedRow(oSheet As Object) As Integer
        '''Gibt die letzte verwendete Zeile als Integer zurück.'''
    
        Dim oCell
        Dim oCursor
        Dim aAddress
        
        oCell = oSheet.getCellByPosition(0, 0)
        oCursor = oSheet.createCursorByRange(oCell)
        oCursor.gotoEndOfUsedArea(True)
        aAddress = oCursor.RangeAddress
        GetLastUsedRow = aAddress.EndRow
    
    End Function ' GetLastUsedRow
    
    
    Function GetLastUsedColumn(oSheet As Object) As Long
        '''Gibt die Nummer der letzten Spalte eines laufenden Datenbereichs in einem Blatt zurück.'''
    
        Dim oCell
        Dim oCursor
        Dim aAddress
        
        oCell = oSheet.getCellByPosition(0, 0)
        oCursor = oSheet.createCursorByRange(oCell)
        oCursor.gotoEndOfUsedArea(True)
        aAddress = oCursor.RangeAddress
        GetLastUsedColumn = aAddress.EndColumn
    
    End Function ' GetLastUsedColumn
    
    
    Function GetPath() As String
        '''Gibt den Pfad zurück.'''
    
        Dim oPathSettings, oFolderDialog
        Dim sPath As String
        
        oPathSettings = CreateUnoService("com.sun.star.util.PathSettings")
        sPath = oPathSettings.Work
        oFolderDialog = CreateUnoService("com.sun.star.ui.dialogs.FolderPicker")
        oFolderDialog.SetDisplayDirectory(sPath)
        If oFolderDialog.Execute() = com.sun.star.ui.dialogs.ExecutableDialogResults.OK Then
            sPath = oFolderDialog.GetDirectory
        Else
            GetPath = ""
            Exit Function
        End If
    
        If Right(sPath, 1) <> "/" Then sPath = sPath & "/"
    
        GetPath = sPath
    
    End Function ' GetPath()
    
    
    Sub export_pdf (sFileName As String)
        
        Dim args1(1)    As New com.sun.star.beans.PropertyValue
        
        args1(0).Name = "ExportFormFields"   ' zeigt nur den Inhalt der Form.Fields
        args1(0).Value= TRUE
        args1(1).Name = "Printing"           ' das braucht niemand
        args1(1).Value= 0                    ' mehr Optionen können hier eingefügt werden
        
        Dim args2(2) As New com.sun.star.beans.PropertyValue
        
        args2(0).Name = "FilterName"
        args2(0).Value = "calc_pdf_Export"
        args2(1).Name = "FilterData"
        args2(1).Value = args1
        args2(2).Name = "SelectionOnly"
        ' Nur der ausgewählte Druckbereich wird exportiert werden.
        args2(2).Value = TRUE
        
        ThisComponent.storeToURL(sFileName,args2())
    
    End Sub ' export_pdf

    = ODS Datei, um das Makro zu testen