Jump to content

マクロ/Calc/016

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


説明

このマクロは、CalcシートをPDFにエクスポートします。 これは、マクロを使用せずに ファイル ▸ PDFとしてエクスポート ... から "選択/選択したシート(s)" を選択することで実行できます。ただし、次に示すように、マクロを使用してこのプロセスを自動化/カスタマイズすることも出来ます。

この方法は、オペレーティング・システムに依存しません。

すべての印刷範囲が削除され、シートの使用領域が 印刷範囲 として定義され、PDFとしてエクスポートされます。

Main からサブルーチンを実行ます。そこでは引用符内にシート名を指定しておきます。

その後、マクロを使用できるようになります。以下に示すような Calc ファイルからマクロを開始するだけです。

Code

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

' (^) オプションが明示的に動作するように、Dim を実装する必要があります。
' それ以外は、マクロは機能しています。


Sub Main()

    ExportToPDF ("Sheet1")  ' put Calc sheet name here

End Sub ' Main


Sub ExportToPDF (sSheetName As String)

    MsgBox "PDFのエキスポート先のパスを選択"
    sPath = GetPath

    If sPath = "" Then
        MsgBox "無効なファイルパスです。", 16, "エラー"
        GoTo Section1
    End If

    Section0:
    sStandard = "PDF_Export_" & sSheetName  & "_" & Format(Now,"yyyy-mm-dd") & "_" & Format(Now, "hhmm")

    sName=InputBox ("名前を入力してください " & Chr(10) & _
                "PDFファイル用" , "PDF ファイル名", sStandard )
    If sName="" Then
        nVar = MsgBox ("名前が指定されていません。 " & Chr(10) & _
                    "名前を入力してください。 " & Chr(10) & _
                    """キャンセル"" をクリックした場合, " & Chr(10) & _
                    "エクスポートを停止します。", 1, "エラー")
        If nVar = 1 Then   ' 「はい」がクリックされました。
            GoTo Section0
        Else
            GoTo Section1
        End If
    End If

    sFileName= sName & ".pdf"
    If FileExists(sPath & sFileName) Then
        nVar=MsgBox ("ファイルは既に存在します。 " & Chr(10) & _
                    "ファイルを置き換えますか? " & Chr(10) & _
                    Chr(10) & _
                    """キャンセル"" をクリックした場合, " & Chr(10) & _
                    "エクスポートを停止します。" & Chr(10) & _
                    """いいえ"" をクリックした場合," & Chr(10) & _
                    "別のファイル名を指定できます。", 3, "エラー")
        Select Case nVar
            Case 2        ' 「キャンセル」が押されました
                GoTo Section1
            Case 6        ' 「はい」が押されました
            Case 7        ' 「いいえ」が押されました
                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 "PDFが正常に作成されました。" , 0, "ExportToPDF()"

    Section1:
        ThisComponent.UnlockControllers
        ThisComponent.removeActionLock

End Sub ' ExportToPDF()


Sub Delete_PrintAreas()
    '''すべての印刷領域を削除します。'''

    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)
    '''印刷領域を定義します。'''

    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
    '''最後に使用された行の整数値を返します。'''

    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
    '''シート内の連続したデータ範囲の最後の列の番号を返します。'''

    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
    '''パスを返します。'''

    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"   ' 「Form.Fields」の内容を表示するだけです。
    args1(0).Value= TRUE
    args1(1).Name = "Printing"           ' それは必要ない
    args1(1).Value= 0                    ' ここに更にオプションを追加できます。
    
    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"
    ' 選択した印刷領域のみがエキスポートされます。
    args2(2).Value = TRUE
    
    ThisComponent.storeToURL(sFileName,args2())

End Sub ' export_pdf

マクロテスト用の ODS ファイル