マクロ/Calc/016
Appearance
TDF LibreOffice Document Liberation Project Community Blogs Weblate Nextcloud Redmine Ask LibreOffice Donate
説明
このマクロは、Calcシートを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