Exporter une feuille en PDF

    From The Document Foundation Wiki
    < Macros‎ | Calc
    This page is a translated version of the page Macros/Calc/016 and the translation is 95% complete.
    Outdated translations are marked like this.


    Description

    Cette macro permet d'exporter une feuille de classeur au format PDF.

    Cette solution fonctionne indépendemment du système.

    Le macro permet d'exporter une feuille de classeur au format PDF, quelles que soient la sélection ou les zones d'impression définies pour les autres feuilles. Elle utilise les zones d'impression de la feuille si une ou plusieurs on été définies. Dans le cas contraire toute la feuille est exportée.

    Le code doit être personnalisé en indiquant le nom de la feuille à exporter dans la procédure Sub Main.

    La macro :

    • demande le dossier de destination et le nom souhaité pour le PDF,
    • vérifie l'existence du fichier (possibilité de changer de nom ou d'écraser le document existant),
    • vérifie l'existence de zones d'impression pour la feuille,
      • si oui, utilisation des zones d'impression,
      • si non, récupération de l'adresse de la dernière cellule * utilisée puis sélection de toute la plage concernée,
    • exporte le document.

    Code

    En 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
    
    ' Il faut encore implémenter les Dims pour que le Option Explicit  fonctionne...
    ' A part ça, la macro fonctionne.
    
    
    Sub Main()
    
        ExportToPDF ("Feuille1")  ' put Calc sheet name here
    
    End Sub ' Main
    
    
    Sub ExportToPDF (sSheetName As String)
    
        MsgBox "Choisissez le chemin du lieu d'exportation PDF"
        sPath = GetPath
    
        If sPath = "" Then
            MsgBox "Vous n'avez pas sélectionné de dossier", 16, "Export interrompu"
            GoTo Section1
        End If
    
        Section0:
        sStandard = "PDF_Export_" & sSheetName  & "_" & Format(Now,"yyyy-mm-dd") & "_" & Format(Now, "hhmm")
    
        sName=InputBox ("Donner un nom sans extension " & Chr(10) & _
                    "pour le PDF" , "Nom du PDF", sStandard )
        If sName="" Then
            nVar = MsgBox ("Vous n'avez pas donné de nom pour le PDF " & Chr(10) & _
                        "Veuillez donner un nom. " & Chr(10) & _
                        "Si vous cliquez sur "Annuler", " & Chr(10) & _
                        "l'exportation sera arrêtée.", 1, "Export interrompu")
            If nVar = 1 Then   ' OK a été cliqué
                GoTo Section0
            Else
                GoTo Section1
            End If
        End If
    
        sFileName= sName & ".pdf"
        If FileExists(sPath & sFileName) Then
            nVar=MsgBox ("Ce fichier existe déjà. " & Chr(10) & _
                        "Voulez-vous le remplacer ? " & Chr(10) & _
                        Chr(10) & _
                        "Si vous cliquez sur "Annuler", " & Chr(10) & _
                        "l'exportation sera arrêtée" & Chr(10) & _
                        "Si vous cliquez sur "Annuler"," & Chr(10) & _
                        "vous pourriez saisir un autre nom", 3, "Export interrompu")
            Select Case nVar
                Case 2        ' Annuler a été cliqué
                    GoTo Section1
                Case 6        ' Oui a été cliqué
                Case 7        ' Non a été cliqué
                    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 "Le PDF a été créé avec succès." , 0, "ExportToPDF()"
    
        Section1:
            ThisComponent.UnlockControllers
            ThisComponent.removeActionLock
    
    End Sub ' ExportToPDF()
    
    
    Sub Delete_PrintAreas()
        '''Supprimez toutes les zones d'impression.'''
    
        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)
        '''Définissez la zone d'impression.'''
    
        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
        '''Retourne l'entier de la dernière ligne utilisée.'''
    
        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
        '''Renvoie le numéro de la dernière colonne d'une série de données continues dans une feuille.'''
    
        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
        '''Rendra le chemin.'''
    
        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"   ' afficher le contenu du formulaire
        args1(0).Value= TRUE
        args1(1).Name = "Printing"           ' n'ai pas besoin de ca
        args1(1).Value= 0                    ' d'autres options pourraient être ajoutées ici
        
        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"
        ' <span lang="en" dir="ltr" class="mw-content-ltr">Only the selected printing Area will we exported.</span>
        args2(2).Value = TRUE
        
        ThisComponent.storeToURL(sFileName,args2())
    
    End Sub ' export_pdf

    Fichier ODT pour tester la macro