Quelle SF_Calc.xba
Sprache: unbekannt
|
|
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module. dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Calc" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
REM === The SFDocuments library is one of the associated libraries. ===
REM === Full documentation is available on https://help.libreoffice.org/ ===
REM =======================================================================================================================
Option Compatible
Option ClassModule
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' SF_Calc
''' =======
'''
''' The SFDocuments library gathers a number of methods and properties making easy
''' managing and manipulating LibreOffice documents
'''
''' Some methods are generic for all types of documents: they are combined in the SF_Document module.
''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Base, ...
'''
''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary
''' Each subclass MUST implement also the generic methods and properties, even if they only call
''' the parent methods and properties.
''' They should also duplicate some generic private members as a subset of their own set of members
'''
''' The SF_Calc module is focused on :
''' - management (copy, insert, move, ...) of sheets within a Calc document
''' - exchange of data between Basic data structures and Calc ranges of values
''' - copying and importing massive amounts of data
''' - simple and selective formatting options
'''
''' The current module is closely related to the "UI" service of the ScriptForge library
'''
''' Service invocation examples:
''' 1) From the UI service
''' Dim ui As Object, oDoc As Object
''' Set ui = CreateScriptService("UI")
''' Set oDoc = ui.CreateDocument("Calc", ...)
''' ' or Set oDoc = ui.OpenDocument("C:\Me\MyFile.ods")
''' 2) Directly if the document is already opened
''' Dim oDoc As Object
''' Set oDoc = CreateScriptService("SFDocuments.Calc", "Untitled 1") ' Default = ActiveWindow
''' ' or Set oDoc = CreateScriptService("SFDocuments.Calc", "Untitled 1") ' Untitled 1 is presumed a Calc document
''' ' The substring "SFDocuments." in the service name is optional
'''
''' Definitions:
'''
''' Many methods require a "Sheet" or a "Range" as argument. (NB: a single cell is considered as a special case of a Range)
''' Usually, within a specific Calc instance, sheets and ranges are given as a string: "SheetX" and "D2:F6"
''' Multiple ranges are not supported in this context.
''' Additionally, the .Sheet and .Range methods return a reference that may be used
''' as argument of a method called from another instance of the Calc service
''' Example:
''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\FileA.ods", Hidden := True, ReadOnly := True)
''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\FileB.ods")
''' oDocB.CopyToRange(oDocA.Range("SheetX.D4:F8"), "D2:F6") ' CopyToRange(source, target)
'''
''' Sheet: the sheet name as a string or an object produced by .Sheet()
''' "~" = current sheet
''' Range: a string designating a set of contiguous cells located in a sheet of the current instance
''' "~" = current selection (if multiple selections, its 1st component)
''' or an object produced by .Range()
''' The sheet name is optional (default = active sheet). Surrounding quotes and $ signs are optional
''' ~.~, ~ The current selection in the active sheet
''' $'SheetX'.D2 or $D$2 A single cell
''' $SheetX.D2:F6, D2:D10 Multiple cells
''' $'SheetX'.A:A or 3:5 All cells in the same column or row up to the last active cell
''' SheetX.* All cells up to the last active cell
''' myRange A range name at spreadsheet level
''' ~.yourRange, SheetX.someRange A range name at sheet level
''' myDoc.Range("SheetX.D2:F6") A range within the sheet SheetX in file associated with the myDoc Calc instance
'''
''' Several methods may receive a "FilterFormula" as argument.
''' A FilterFormula may be associated with a FilterScope: "ROW", "COLUMN" or "CELL".
''' These arguments determine on which rows/columns/cells of a range the method should be applied
''' Examples:
''' oDoc.ClearAll("A1:J10", FilterFormula := "=(A1<=0)", FilterScope := "CELL") ' Clear all negative values
''' oDoc.ClearAll("SheetX.A1:J10", "=SUM(SheetX.A1:A10)>100", "COLUMN") ' Clear all columns whose sum is greater than 100
'''
''' FilterFormula: a Calc formula that returns TRUE or FALSE
''' the formula is expressed in terms of
''' - the top-left cell of the range when FilterScope = "CELL"
''' - the topmost row of the range when FilterScope = "ROW"
''' - the leftmost column of the range when FilterScope = "COLUMN"
''' relative and absolute references will be interpreted correctly
''' FilterScope: the way the formula is applied, once by row, by column, or by individual cell
'''
''' Detailed user documentation:
''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_calc.html?DbPAR=BASIC
'''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
REM ================================================================== EXCEPTIONS
Private Const UNKNOWNFILEERROR = "UNKNOWNFILEERROR"
Private Const BASEDOCUMENTOPENERROR = "BASEDOCUMENTOPENERROR"
Private Const CALCADDRESSERROR = "CALCADDRESSERROR"
Private Const DUPLICATESHEETERROR = "DUPLICATESHEETERROR"
Private Const OFFSETADDRESSERROR = "OFFSETADDRESSERROR"
Private Const CALCFORMNOTFOUNDERROR = "CALCFORMNOTFOUNDERROR"
Private Const DUPLICATECHARTERROR = "DUPLICATECHARTERROR"
Private Const RANGEEXPORTERROR = "RANGEEXPORTERROR"
REM ============================================================= PRIVATE MEMBERS
Private [Me] As Object
Private [_Super] As Object ' Document superclass, which the current instance is a subclass of
Private ObjectType As String ' Must be CALC
Private ServiceName As String
' Window component
Private _Component As Object ' com.sun.star.lang.XComponent
Type _Address
ObjectType As String ' Must be "SF_CalcReference"
ServiceName As String ' Must be "SFDocuments.CalcReference"
RawAddress As String
Component As Object ' com.sun.star.lang.XComponent
SheetName As String
SheetIndex As Integer
RangeName As String
Height As Long
Width As Long
XSpreadSheet As Object ' com.sun.star.sheet.XSpreadsheet
XCellRange As Object ' com.sun.star.table.XCellRange
End Type
Private _LastParsedAddress As Object ' _Address type - parsed ranges are cached
REM ============================================================ MODULE CONSTANTS
Private Const cstSHEET = 1
Private Const cstRANGE = 2
Private Const MAXCOLS = 2^14 ' Max number of columns in a sheet
Private Const MAXROWS = 2^20 ' Max number of rows in a sheet
Private Const CALCREFERENCE = "SF_CalcReference" ' Object type of _Address
Private Const SERVICEREFERENCE = "SFDocuments.CalcReference"
' Service name of _Address (used in Python)
Private Const ISCALCFORM = 2 ' Form is stored in a Calc document
Private Const cstSPECIALCHARS = " `~!@#$%^&()-_=+{}|;,<.>"""
' Presence of a special character forces surrounding the sheet name with single quotes in absolute addresses
REM ====================================================== CONSTRUCTOR/DESTRUCTOR
REM -----------------------------------------------------------------------------
Private Sub Class_Initialize()
Set [Me] = Nothing
Set [_Super] = Nothing
ObjectType = "CALC"
ServiceName = "SFDocuments.Calc"
Set _Component = Nothing
Set _LastParsedAddress = Nothing
End Sub ' SFDocuments.SF_Calc Constructor
REM -----------------------------------------------------------------------------
Private Sub Class_Terminate()
Call Class_Initialize()
End Sub ' SFDocuments.SF_Calc Destructor
REM -----------------------------------------------------------------------------
Public Function Dispose() As Variant
If Not IsNull([_Super]) Then Set [_Super] = [_Super].Dispose()
Call Class_Terminate()
Set Dispose = Nothing
End Function ' SFDocuments.SF_Calc Explicit Destructor
REM ================================================================== PROPERTIES
REM -----------------------------------------------------------------------------
Property Get CurrentSelection() As Variant
''' Returns as a string the currently selected range or as an array the list of the currently selected ranges
CurrentSelection = _PropertyGet("CurrentSelection")
End Property ' SFDocuments.SF_Calc.CurrentSelection (get)
REM -----------------------------------------------------------------------------
Property Let CurrentSelection(Optional ByVal pvSelection As Variant)
''' Set the selection to a single or a multiple range
''' The argument is a string or an array of strings
Dim sRange As String ' A single selection
Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges
Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress
Dim i As Long
Const cstThisSub = "SFDocuments.Calc.setCurrentSelection"
Const cstSubArgs = "Selection"
On Local Error GoTo Catch
Check:
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive(True) Then GoTo Finally
If IsArray(pvSelection) Then
If Not ScriptForge.SF_Utils._ValidateArray(pvSelection, "pvSelection", 1, V_STRING, True) Then GoTo Finally
Else
If Not ScriptForge.SF_Utils._Validate(pvSelection, "pvSelection", V_STRING) Then GoTo Finally
End If
End If
Try:
If IsArray(pvSelection) Then
Set oCellRanges = _Component.createInstance("com.sun.star.sheet.SheetCellRanges")
vRangeAddresses = Array()
ReDim vRangeAddresses(0 To UBound(pvSelection))
For i = 0 To UBound(pvSelection)
vRangeAddresses(i) = Range(pvSelection(i)).XCellRange.RangeAddress
Next i
oCellRanges.addRangeAddresses(vRangeAddresses, False)
_Component.CurrentController.select(oCellRanges)
Else
_Component.CurrentController.select(_ParseAddress(pvSelection).XCellRange)
End If
Finally:
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Property
Catch:
GoTo Finally
End Property ' SFDocuments.SF_Calc.CurrentSelection (let)
REM -----------------------------------------------------------------------------
Property Get DefinedNames() As Variant
''' Returns the full sorted list of all named ranges in the document
DefinedNames = _PropertyGet("DefinedNames")
End Property ' SFDocuments.SF_Calc.DefinedNames
REM -----------------------------------------------------------------------------
Property Get FirstCell(Optional ByVal RangeName As Variant) As String
''' Returns the First used cell in a given range or sheet
''' When the argument is a sheet it will always return the "sheet.$A$1" cell
FirstCell = _PropertyGet("FirstCell", RangeName)
End Property ' SFDocuments.SF_Calc.FirstCell
REM -----------------------------------------------------------------------------
Property Get FirstColumn(Optional ByVal RangeName As Variant) As Long
''' Returns the leftmost column in a given sheet or range
''' When the argument is a sheet it will always return 1
FirstColumn = _PropertyGet("FirstColumn", RangeName)
End Property ' SFDocuments.SF_Calc.FirstColumn
REM -----------------------------------------------------------------------------
Property Get FirstRow(Optional ByVal RangeName As Variant) As Long
''' Returns the First used column in a given range
''' When the argument is a sheet it will always return 1
FirstRow = _PropertyGet("FirstRow", RangeName)
End Property ' SFDocuments.SF_Calc.FirstRow
REM -----------------------------------------------------------------------------
Property Get Height(Optional ByVal RangeName As Variant) As Long
''' Returns the height in # of rows of the given range
Height = _PropertyGet("Height", RangeName)
End Property ' SFDocuments.SF_Calc.Height
REM -----------------------------------------------------------------------------
Property Get LastCell(Optional ByVal RangeName As Variant) As String
''' Returns the last used cell in a given sheet or range
LastCell = _PropertyGet("LastCell", RangeName)
End Property ' SFDocuments.SF_Calc.LastCell
REM -----------------------------------------------------------------------------
Property Get LastColumn(Optional ByVal RangeName As Variant) As Long
''' Returns the last used column in a given sheet
LastColumn = _PropertyGet("LastColumn", RangeName)
End Property ' SFDocuments.SF_Calc.LastColumn
REM -----------------------------------------------------------------------------
Property Get LastRow(Optional ByVal RangeName As Variant) As Long
''' Returns the last used column in a given sheet
LastRow = _PropertyGet("LastRow", RangeName)
End Property ' SFDocuments.SF_Calc.LastRow
REM -----------------------------------------------------------------------------
Property Get Range(Optional ByVal RangeName As Variant) As Variant
''' Returns a (internal) range object
Range = _PropertyGet("Range", RangeName)
End Property ' SFDocuments.SF_Calc.Range
REM -----------------------------------------------------------------------------
Property Get Region(Optional ByVal RangeName As Variant) As String
''' Returns the smallest area as a range string that contains the given range
''' and which is completely surrounded with empty cells
Region = _PropertyGet("Region", RangeName)
End Property ' SFDocuments.SF_Calc.Region
REM -----------------------------------------------------------------------------
Property Get Sheet(Optional ByVal SheetName As Variant) As Variant
''' Returns a (internal) sheet object
Sheet = _PropertyGet("Sheet", SheetName)
End Property ' SFDocuments.SF_Calc.Sheet
REM -----------------------------------------------------------------------------
Property Get SheetName(Optional ByVal RangeName As Variant) As String
''' Returns the sheet name part of a range
SheetName = _PropertyGet("SheetName", RangeName)
End Property ' SFDocuments.SF_Calc.SheetName
REM -----------------------------------------------------------------------------
Property Get Sheets() As Variant
''' Returns an array listing the existing sheet names
Sheets = _PropertyGet("Sheets")
End Property ' SFDocuments.SF_Calc.Sheets
REM -----------------------------------------------------------------------------
Property Get Width(Optional ByVal RangeName As Variant) As Long
''' Returns the width in # of columns of the given range
Width = _PropertyGet("Width", RangeName)
End Property ' SFDocuments.SF_Calc.Width
REM -----------------------------------------------------------------------------
Property Get XCellRange(Optional ByVal RangeName As Variant) As Variant
''' Returns a UNO object of type com.sun.star.Table.CellRange
XCellRange = _PropertyGet("XCellRange", RangeName)
End Property ' SFDocuments.SF_Calc.XCellRange
REM -----------------------------------------------------------------------------
Property Get XRectangle(Optional ByVal RangeName As Variant) As Variant
''' Returns a UNO structure of type com.sun.star.awt.Rectangle
''' describing the area in pixels on the screen where the range is located.
''' Useful in the context of running mouse events and widgets like popup menus
XRectangle = _PropertyGet("XRectangle", RangeName)
End Property ' SFDocuments.SF_Calc.XRectangle
REM -----------------------------------------------------------------------------
Property Get XSheetCellCursor(Optional ByVal RangeName As Variant) As Variant
''' Returns a UNO object of type com.sun.star.sheet.XSheetCellCursor
'' After having moved the cursor (gotoNext(), ...) the resulting range can be got
''' back as a string with the cursor.AbsoluteName UNO property.
XSheetCellCursor = _PropertyGet("XSheetCellCursor", RangeName)
End Property ' SFDocuments.SF_Calc.XSheetCellCursor
REM -----------------------------------------------------------------------------
Property Get XSpreadsheet(Optional ByVal SheetName As Variant) As Variant
''' Returns a UNO object of type com.sun.star.sheet.XSpreadsheet
XSpreadsheet = _PropertyGet("XSpreadsheet", SheetName)
End Property ' SFDocuments.SF_Calc.XSpreadsheet
REM ===================================================================== METHODS
REM -----------------------------------------------------------------------------
Public Function A1Style(Optional ByVal Row1 As Variant _
, Optional ByVal Column1 As Variant _
, Optional ByVal Row2 As Variant _
, Optional ByVal Column2 As Variant _
, Optional ByVal SheetName As Variant _
) As String
''' Returns a range expressed in A1-style as defined by its coordinates
''' If only one pair of coordinates is given, the range will embrace only a single cell
''' Args:
''' Row1 : the row number of the first coordinate
''' Column1 : the column number of the first coordinates
''' Row2 : the row number of the second coordinate
''' Column2 : the column number of the second coordinates
''' SheetName: Default = the current sheet. If present, the sheet must exist.
''' Returns:
''' A range as a string
''' Exceptions:
''' Examples:
''' range = oDoc.A1Style(5, 2, 10, 4, "SheetX") ' "'$SheetX'.$E$2:$J$4"
Dim sA1Style As String ' Return value
Dim vSheetName As Variant ' Alias of SheetName - necessary see [Bug 145279]
Dim lTemp As Long ' To switch 2 values
Dim i As Long
Const cstThisSub = "SFDocuments.Calc.A1Style"
Const cstSubArgs = "Row1, Column1, [Row2], [Column2], [SheetName]="""""
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
sA1Style = ""
Check:
If IsMissing(Row2) Or IsEmpty(Row2) Then Row2 = 0
If IsMissing(Column2) Or IsEmpty(Column2) Then Column2 = 0
If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = ""
vSheetName = SheetName
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive() Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Row1, "Row1", ScriptForge.V_NUMERIC) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Column1, "Column1", ScriptForge.V_NUMERIC) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Row2, "Row2", ScriptForge.V_NUMERIC) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Column2, "Column2", ScriptForge.V_NUMERIC) Then GoTo Finally
If Not _ValidateSheet(vSheetName, "SheetName", , True, True, , , True) Then GoTo Finally
End If
If Row1 > MAXROWS Then Row1 = MAXROWS
If Row2 > MAXROWS Then Row2 = MAXROWS
If Column1 > MAXCOLS Then Column1 = MAXCOLS
If Column2 > MAXCOLS Then Column2 = MAXCOLS
If Row1 <= 0 Or Column1 <= 0 Then GoTo Catch
If Row2 = Row1 And Column2 = Column1 Then ' Single cell
Row2 = 0
Column2 = 0
End If
If Row2 > 0 And Row2 < Row1 Then
lTemp = Row2 : Row2 = Row1 : Row1 = lTemp
End If
If Column2 > 0 And Column2 < Column1 Then
lTemp = Column2 : Column2 = Column1 : Column1 = lTemp
End If
Try:
' Surround the sheet name with single quotes when required by the presence of special characters
If Len(vSheetName) > 0 Then vSheetName = "$" & _QuoteSheetName(vSheetName) & "."
' Define the new range string
sA1Style = vSheetName _
& "$" & _GetColumnName(Column1) & "$" & CLng(Row1) _
& Iif(Row2 > 0 And Column2 > 0, ":$" & _GetColumnName(Column2) & "$" & CLng(Row2), "")
Finally:
A1Style = sA1Style
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDocuments.SF_Calc.A1Style
REM -----------------------------------------------------------------------------
Public Function Activate(Optional ByVal SheetName As Variant) As Boolean
''' Make the current document or the given sheet active
''' Args:
''' SheetName: Default = the Calc document as a whole
''' Returns:
''' True if the document or the sheet could be made active
''' Otherwise, there is no change in the actual user interface
''' Examples:
''' oDoc.Activate("SheetX")
Dim bActive As Boolean ' Return value
Dim oSheet As Object ' Reference to sheet
Const cstThisSub = "SFDocuments.Calc.Activate"
Const cstSubArgs = "[SheetName]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
bActive = False
Check:
If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = ""
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive() Then GoTo Finally
If Not _ValidateSheet(SheetName, "SheetName", , , True) Then GoTo Finally
End If
Try:
' Sheet activation, to do only when meaningful, precedes document activation
If Len(SheetName) > 0 Then
With _Component
Set oSheet = .getSheets.getByName(SheetName)
Set .CurrentController.ActiveSheet = oSheet
End With
End If
bActive = [_Super].Activate()
Finally:
Activate = bActive
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDocuments.SF_Calc.Activate
REM -----------------------------------------------------------------------------
Public Function AlignRange(Optional ByVal TargetRange As Variant _
, Optional ByVal Alignment As Variant _
, Optional ByVal FilterFormula As Variant _
, Optional ByVal FilterScope As Variant _
) As String
''' Align horizontally or vertically a range of cells.
''' The impacted cells may be determined with a filter formula and its scope.
''' Args:
''' TargetRange : the cell or the range as a string in which cells should be re-aligned.
''' Alignment: a string combining 1 or 2 of next characters (other characters are ignored):
''' L align Left
''' R align Right
''' C Center gorizontally
''' B align Bottom
''' M center vertically (Middle)
''' T align Top
''' FilterFormula: a Calc formula to select among the given TargetRange
''' When left empty, the alignments are applied on the full range
''' FilterScope: "CELL", "ROW" or "COLUMN"
''' When FilterFormula is present, FilterScope is mandatory
''' Returns:
''' A string representing the updated range
''' Examples:
''' oDoc.AlignRange("SheetX.A1:J30", "Middle,Center", FilterFormula := "IsNumeric(A1), FilterScope := "CELL")
''' ' Align to the middle of the cells, horizontally and vertically
Dim sAlign As String ' Return value
Dim oRange As Object ' Alias of TargetRange
Dim vRanges() As Variant ' Array of subranges resulting from the application of the filter
Dim oARange As Object ' A single element of vRanges
Const cstThisSub = "SFDocuments.Calc.AlignRange"
Const cstSubArgs = "TargetRange, Alignment, [FilterFormula=""""], [FilterScope=""""]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
sAlign = ""
Check:
If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = ""
If IsMissing(FilterScope) Or IsEmpty(FilterScope) Then FilterScope = ""
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive() Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Alignment, "Alignment", V_STRING) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally
If Len(FilterFormula) > 0 Then
If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING, Array("CELL", "ROW", "COLUMN")) Then GoTo Finally
Else
If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING) Then GoTo Finally
End If
End If
Try:
If VarType(TargetRange) = V_STRING Then Set oRange = _ParseAddress(TargetRange) Else Set oRange = TargetRange
' Without filter, the whole range is re-aligned
' Otherwise the filter cuts the range in subranges and formats them one by one
If Len(FilterFormula) = 0 Then vRanges = Array(oRange) Else vRanges() = _ComputeFilter(oRange, FilterFormula, UCase(FilterScope))
For Each oARange In vRanges
With oARange.XCellRange
If InStr(1, Alignment, "L", 0) > 0 Then .ParaAdjust = com.sun.star.style.ParagraphAdjust.LEFT
If InStr(1, Alignment, "C", 0) > 0 Then .ParaAdjust = com.sun.star.style.ParagraphAdjust.CENTER
If InStr(1, Alignment, "R", 0) > 0 Then .ParaAdjust = com.sun.star.style.ParagraphAdjust.RIGHT
If InStr(1, Alignment, "B", 0) > 0 Then .VertJustify = com.sun.star.table.CellVertJustify.BOTTOM
If InStr(1, Alignment, "M", 0) > 0 Then .VertJustify = com.sun.star.table.CellVertJustify.CENTER
If InStr(1, Alignment, "T", 0) > 0 Then .VertJustify = com.sun.star.table.CellVertJustify.TOP
End With
Next oARange
sAlign = oRange.RangeName
Finally:
AlignRange = sAlign
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDocuments.SF_Calc.AlignRange
REM -----------------------------------------------------------------------------
Public Function BorderRange(Optional ByVal TargetRange As Variant _
, Optional ByVal Borders As Variant _
, Optional ByVal FilterFormula As Variant _
, Optional ByVal FilterScope As Variant _
) As String
''' Apply within and around a range of cells a set of line borders.
''' The impacted cells may be determined with a filter formula and its scope.
''' All the borders have the same standard width, style and color.
''' Pre-existing border lines in the impacted cells, rows or columns
''' are first cleared. Other cells in the range are left untouched.
''' To clear the full range use Border = "" without the FilterFormula argument.
''' Args:
''' TargetRange : the cell or the range as a string on which borders should be applied
''' Borders: a string combining next characters (other characters are ignored):
''' B Bottom outer line
''' L Left outer line
''' T Top outer line
''' R Right outer line
''' H Horizontal inner line
''' V Vertical inner line
''' U diagonal bottom-Up line
''' D diagonal top-Down line
''' FilterFormula: a Calc formula to select among the given TargetRange
''' When left empty, the given borders are applied on the full range
''' FilterScope: "CELL", "ROW" or "COLUMN"
''' When FilterFormula is present, FilterScope is mandatory
''' Returns:
''' A string representing the updated range
''' Examples:
''' oDoc.BorderRange("SheetX.A1:J30", "HB", FilterFormula := "IsNumeric(A1), FilterScope := "CELL")
''' ' Border with a bottom line, including the horizontal inner lines
Dim sBorder As String ' Return value
Dim oRange As Object ' Alias of TargetRange
Dim vRanges() As Variant ' Array of subranges resulting from the application of the filter
Dim oBRange As Object ' A single element of vRanges
Const cstThisSub = "SFDocuments.Calc.BorderRange"
Const cstSubArgs = "TargetRange, Borders, [FilterFormula=""""], [FilterScope=""""]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
sBorder = ""
Check:
If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = ""
If IsMissing(FilterScope) Or IsEmpty(FilterScope) Then FilterScope = ""
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive() Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Borders, "Borders", V_STRING) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally
If Len(FilterFormula) > 0 Then
If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING, Array("CELL", "ROW", "COLUMN")) Then GoTo Finally
Else
If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING) Then GoTo Finally
End If
End If
Try:
If VarType(TargetRange) = V_STRING Then Set oRange = _ParseAddress(TargetRange) Else Set oRange = TargetRange
' Without filter, the whole range gets new borders
' Otherwise the filter cuts the range in subranges and formats them one by one
If Len(FilterFormula) = 0 Then vRanges = Array(oRange) Else vRanges() = _ComputeFilter(oRange, FilterFormula, UCase(FilterScope))
For Each oBRange In vRanges
_BorderRange(oBRange, Borders)
Next oBRange
sBorder = oRange.RangeName
Finally:
BorderRange = sBorder
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDocuments.SF_Calc.BorderRange
REM -----------------------------------------------------------------------------
Public Function Charts(Optional ByVal SheetName As Variant _
, Optional ByVal ChartName As Variant _
) As Variant
''' Return either the list of charts present in the given sheet or a chart object
''' Args:
''' SheetName: The name of an existing sheet
''' ChartName: The user-defined name of the targeted chart or the zero-length string
''' Returns:
''' When ChartName = "", return the list of the charts present in the sheet,
''' otherwise, return a new chart service instance
''' Examples:
''' Dim oChart As Object
''' Set oChart = oDoc.Charts("SheetX", "myChart")
Dim vCharts As Variant ' Return value when array of chart names
Dim oChart As Object ' Return value when new chart instance
Dim oSheet As Object ' Alias of SheetName as reference
Dim oDrawPage As Object ' com.sun.star.drawing.XDrawPage
Dim oNextShape As Object ' com.sun.star.drawing.XShape
Dim sChartName As String ' Some chart name
Dim lCount As Long ' Counter for charts among all drawing objects
Dim i As Long
Const cstChartShape = "com.sun.star.drawing.OLE2Shape"
Const cstThisSub = "SFDocuments.Calc.Charts"
Const cstSubArgs = "SheetName, [ChartName=""""]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
vCharts = Array()
Check:
If IsMissing(ChartName) Or IsEmpty(ChartName) Then ChartName = ""
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive(True) Then GoTo Finally
If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING) Then GoTo Finally
End If
Try:
' Because the user can change it constantly, the list of valid charts has to be rebuilt at each time
' Explore charts starting from the draw page
Set oSheet = _Component.getSheets.getByName(SheetName)
Set oDrawPage = oSheet.getDrawPage()
vCharts = Array()
Set oChart = Nothing
lCount = -1
For i = 0 To oDrawPage.Count - 1
Set oNextShape = oDrawPage.getByIndex(i)
if oNextShape.supportsService(cstChartShape) Then ' Ignore other shapes
sChartName = oNextShape.Name ' User-defined name
If Len(sChartName) = 0 Then sChartName = oNextShape.PersistName ' Internal name
' Is chart found ?
If Len(ChartName) > 0 Then
If ChartName = sChartName Then
Set oChart = New SF_Chart
With oChart
Set .[Me] = oChart
Set .[_Parent] = [Me]
._SheetName = SheetName
._DrawIndex = i
._ChartName = ChartName
._PersistentName = oNextShape.PersistName
Set ._Shape = oNextShape
Set ._Chart = oSheet.getCharts().getByName(._PersistentName)
Set ._ChartObject = ._Chart.EmbeddedObject
Set ._Diagram = ._ChartObject.Diagram
End With
Exit For
End If
End If
' Build stack of chart names
lCount = lCount + 1
If UBound(vCharts) < 0 Then
vCharts = Array(sChartName)
Else
ReDim Preserve vCharts(0 To UBound(vCharts) + 1)
vCharts(lCount) = sChartName
End If
End If
Next i
' Raise error when chart not found
If Len(ChartName) > 0 And IsNull(oChart) Then
If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING, vCharts, True) Then GoTo Finally
End If
Finally:
If Len(ChartName) = 0 Then Charts = vCharts Else Set Charts = oChart
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDocuments.SF_Calc.Charts
REM -----------------------------------------------------------------------------
Public Sub ClearAll(Optional ByVal Range As Variant _
, Optional FilterFormula As Variant _
, Optional FilterScope As Variant _
)
''' Clear entirely the given range
''' Args:
''' Range : the cell or the range as a string that should be cleared
''' FilterFormula: a Calc formula to select among the given Range
''' When left empty, all the cells of the range are cleared
''' FilterScope: "CELL" (default value), "ROW" or "COLUMN"
''' When FilterFormula is present, FilterScope is mandatory
''' Examples:
''' oDoc.ClearAll("SheetX") ' Clears the used area of the sheet
''' oDoc.ClearAll("A1:J20", "=($A1=0)", "ROW") ' Clears all rows when 1st cell is zero
_ClearRange("All", Range, FilterFormula, FilterScope)
End Sub ' SFDocuments.SF_Calc.ClearAll
REM -----------------------------------------------------------------------------
Public Sub ClearFormats(Optional ByVal Range As Variant _
, Optional FilterFormula As Variant _
, Optional FilterScope As Variant _
)
''' Clear all the formatting elements of the given range
''' Args:
''' Range : the cell or the range as a string that should be cleared
''' FilterFormula: a Calc formula to select among the given Range
''' When left empty, all the cells of the range are cleared
''' FilterScope: "CELL" (default value), "ROW" or "COLUMN"
''' When FilterFormula is present, FilterScope is mandatory
''' Examples:
''' oDoc.ClearFormats("SheetX.*") ' Clears the used area of the sheet
''' oDoc.ClearFormats("A1:J20", "=(MOD(A1;0)=0)", "CELL") ' Clears all even cells
_ClearRange("Formats", Range, FilterFormula, FilterScope)
End Sub ' SFDocuments.SF_Calc.ClearFormats
REM -----------------------------------------------------------------------------
Public Sub ClearValues(Optional ByVal Range As Variant _
, Optional FilterFormula As Variant _
, Optional FilterScope As Variant _
)
''' Clear values and formulas in the given range
''' Args:
''' Range : the cell or the range as a string that should be cleared
''' FilterFormula: a Calc formula to select among the given Range
''' When left empty, all the cells of the range are cleared
''' FilterScope: "CELL" (default value), "ROW" or "COLUMN"
''' When FilterFormula is present, FilterScope is mandatory
''' Examples:
''' oDoc.ClearValues("SheetX.*") ' Clears the used area of the sheet
''' oDoc.ClearValues("A2:A20", "=(A2=A1)", "CELL") ' Clears all duplicate cells
_ClearRange("Values", Range, FilterFormula, FilterScope)
End Sub ' SFDocuments.SF_Calc.ClearValues
REM -----------------------------------------------------------------------------
Public Function ColorizeRange(Optional ByVal TargetRange As Variant _
, Optional ByVal Foreground As Variant _
, Optional ByVal Background As Variant _
, Optional ByVal FilterFormula As Variant _
, Optional ByVal FilterScope As Variant _
) As String
''' Define fore- and background colors of a range of cells.
''' The impacted cells may be determined with a filter formula and its scope.
''' Args:
''' TargetRange : the cell or the range as a string in which cells should be re-colorizeed.
''' Foreground: the foreground color as the output of the RGB() function
''' Background: the foreground color as the output of the RGB() function
''' FilterFormula: a Calc formula to select among the given TargetRange
''' When left empty, the Colorizements are applied on the full range
''' FilterScope: "CELL", "ROW" or "COLUMN"
''' When FilterFormula is present, FilterScope is mandatory
''' Returns:
''' A string representing the updated range
''' Examples:
''' oDoc.ColorizeRange("SheetX.A1:J30", Background := RGB(255, 0, 0), FilterFormula := "IsNumeric(A1), FilterScope := "CELL")
''' ' Paint the cell(s) in red.
Dim sColorize As String ' Return value
Dim oRange As Object ' Alias of TargetRange
Dim vRanges() As Variant ' Array of subranges resulting from the application of the filter
Dim oCRange As Object ' A single element of vRanges
Const cstThisSub = "SFDocuments.Calc.ColorizeRange"
Const cstSubArgs = "TargetRange, [Foreground=-1], [Background=-1] [FilterFormula=""""], [FilterScope=""""]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
sColorize = ""
Check:
If IsMissing(Foreground) Or IsEmpty(Foreground) Then Foreground = -1
If IsMissing(Background) Or IsEmpty(Background) Then Background = -1
If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = ""
If IsMissing(FilterScope) Or IsEmpty(FilterScope) Then FilterScope = ""
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive() Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Foreground, "Foreground", ScriptForge.V_NUMERIC) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Background, "Background", ScriptForge.V_NUMERIC) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally
If Len(FilterFormula) > 0 Then
If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING, Array("CELL", "ROW", "COLUMN")) Then GoTo Finally
Else
If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING) Then GoTo Finally
End If
End If
Try:
If VarType(TargetRange) = V_STRING Then Set oRange = _ParseAddress(TargetRange) Else Set oRange = TargetRange
' Without filter, the whole range is re-Colorizeed
' Otherwise the filter cuts the range in subranges and formats them one by one
If Len(FilterFormula) = 0 Then vRanges = Array(oRange) Else vRanges() = _ComputeFilter(oRange, FilterFormula, UCase(FilterScope))
For Each oCRange In vRanges
With oCRange.XCellRange
If Foreground >= 0 Then .CharColor = CLng(Foreground)
If Background >= 0 Then .CellBackColor = CLng(Background)
End With
Next oCRange
sColorize = oRange.RangeName
Finally:
ColorizeRange = sColorize
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDocuments.SF_Calc.ColorizeRange
REM -----------------------------------------------------------------------------
Public Function CompactLeft(Optional ByVal Range As Variant _
, Optional ByVal WholeColumn As Variant _
, Optional ByVal FilterFormula As Variant _
) As String
''' Delete the columns of a specified range matching a filter expressed as a formula
''' applied on each column.
''' The deleted cells can span whole columns or be limited to the height of the range
''' The execution of the method has no effect on the current selection
''' Args:
''' Range: the range in which cells have to be erased, as a string
''' WholeColumn: when True (default = False), erase whole columns
''' FilterFormula: the formula to be applied on each column.
''' The column is erased when the formula results in True,
''' The formula shall probably involve one or more cells of the first column of the range.
''' By default, a column is erased when all the cells of the column are empty,
''' i.e. suppose the range is "A1:J200" (height = 200) the default value becomes
''' "=(COUNTBLANK(A1:A200)=200)"
''' Returns:
''' A string representing the location of the initial range after compaction,
''' or the zero-length string if the whole range has been deleted
''' Examples:
''' newrange = oDoc.CompactLeft("SheetX.G1:L10") ' All empty columns of the range are suppressed
''' newrange = oDoc.CompactLeft("SheetX.G1:L10", WholeColumn := True, FilterFormula := "=(G$7=""X"")")
''' ' The columns having a "X" in row 7 are completely suppressed
Dim sCompact As String ' Return value
Dim oCompact As Object ' Return value as an _Address type
Dim lCountDeleted As Long ' Count the deleted columns
Dim vCompactRanges As Variant ' Array of ranges to be compacted based on the formula
Dim oSourceAddress As Object ' Alias of Range as _Address
Dim oPartialRange As Object ' Contiguous columns to be deleted
Dim sShiftRange As String ' Contiguous columns to be shifted
Dim i As Long
Const cstThisSub = "SFDocuments.Calc.CompactLeft"
Const cstSubArgs = "Range, [WholeColumn=False], [FilterFormula=""""]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
sCompact = ""
Check:
If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False
If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = ""
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive(True) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally
End If
Try:
Set oSourceAddress = _ParseAddress(Range)
lCountDeleted = 0
With oSourceAddress
' Set the default formula => all cells are blank
If FilterFormula = "" Then FilterFormula = Printf("=(COUNTBLANK(%C1%R1:%C1%R2)-" & .Height & "=0)", Range)
' Identify the ranges to compact based on the given formula
vCompactRanges = _ComputeFilter(oSourceAddress, FilterFormula, "COLUMN")
' Iterate through the ranges from bottom to top and shift them up
For i = UBound(vCompactRanges) To 0 Step -1
Set oPartialRange = vCompactRanges(i)
ShiftLeft(oPartialRange.RangeName, WholeColumn)
lCountDeleted = lCountDeleted + oPartialRange.Width
Next i
' Compute the final range position
If lCountDeleted > 0 Then
sCompact = Offset(Range, 0, 0, 0, .Width - lCountDeleted)
' Push to the right the cells that migrated leftwards irrelevantly
If Not WholeColumn Then
sShiftRange = Offset(sCompact, 0, .Width - lCountDeleted, , lCountDeleted)
ShiftRight(sShiftRange, WholeColumn := False)
End If
' Conventionally, if all columns are deleted, the returned range is the zero-length string
If .Width = lCountDeleted Then sCompact = ""
Else ' Initial range is left unchanged
sCompact = .RangeName
End If
End With
Finally:
CompactLeft = sCompact
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
' When error, return the original range
If Not IsNull(oSourceAddress) Then sCompact = oSourceAddress.RangeName
GoTo Finally
End Function ' SFDocuments.SF_Calc.CompactLeft
REM -----------------------------------------------------------------------------
Public Function CompactUp(Optional ByVal Range As Variant _
, Optional ByVal WholeRow As Variant _
, Optional ByVal FilterFormula As Variant _
) As String
''' Delete the rows of a specified range matching a filter expressed as a formula
''' applied on each row.
''' The deleted cells can span whole rows or be limited to the width of the range
''' The execution of the method has no effect on the current selection
''' Args:
''' Range: the range in which cells have to be erased, as a string
''' WholeRow: when True (default = False), erase whole rows
''' FilterFormula: the formula to be applied on each row.
''' The row is erased when the formula results in True,
''' The formula shall probably involve one or more cells of the first row of the range.
''' By default, a row is erased when all the cells of the row are empty,
''' i.e. suppose the range is "A1:J200" (width = 10) the default value becomes
''' "=(COUNTBLANK(A1:J1)=10)"
''' Returns:
''' A string representing the location of the initial range after compaction,
''' or the zero-length string if the whole range has been deleted
''' Examples:
''' newrange = oDoc.CompactUp("SheetX.G1:L10") ' All empty rows of the range are suppressed
''' newrange = oDoc.CompactUp("SheetX.G1:L10", WholeRow := True, FilterFormula := "=(G1=""X"")")
''' ' The rows having a "X" in column G are completely suppressed
Dim sCompact As String ' Return value
Dim lCountDeleted As Long ' Count the deleted rows
Dim vCompactRanges As Variant ' Array of ranges to be compacted based on the formula
Dim oSourceAddress As Object ' Alias of Range as _Address
Dim oPartialRange As Object ' Contiguous rows to be deleted
Dim sShiftRange As String ' Contiguous rows to be shifted
Dim i As Long
Const cstThisSub = "SFDocuments.Calc.CompactUp"
Const cstSubArgs = "Range, [WholeRow=False], [FilterFormula=""""]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
sCompact = ""
Check:
If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False
If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = ""
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive(True) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally
End If
Try:
Set oSourceAddress = _ParseAddress(Range)
lCountDeleted = 0
With oSourceAddress
' Set the default formula => all cells are blank
If FilterFormula = "" Then FilterFormula = Printf("=(COUNTBLANK(%C1%R1:%C2%R1)-" & .Width & "=0)", Range)
' Identify the ranges to compact based on the given formula
vCompactRanges = _ComputeFilter(oSourceAddress, FilterFormula, "ROW")
' Iterate through the ranges from bottom to top and shift them up
For i = UBound(vCompactRanges) To 0 Step -1
Set oPartialRange = vCompactRanges(i)
ShiftUp(oPartialRange.RangeName, WholeRow)
lCountDeleted = lCountDeleted + oPartialRange.Height
Next i
' Compute the final range position
If lCountDeleted > 0 Then
sCompact = Offset(Range, 0, 0, .Height - lCountDeleted, 0)
' Push downwards the cells that migrated upwards irrelevantly
If Not WholeRow Then
sShiftRange = Offset(sCompact, .Height - lCountDeleted, 0, lCountDeleted)
ShiftDown(sShiftRange, WholeRow := False)
End If
' Conventionally, if all rows are deleted, the returned range is the zero-length string
If .Height = lCountDeleted Then sCompact = ""
Else ' Initial range is left unchanged
sCompact = .RangeName
End If
End With
Finally:
CompactUp = sCompact
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
' When error, return the original range
If Not IsNull(oSourceAddress) Then sCompact = oSourceAddress.RangeName
GoTo Finally
End Function ' SFDocuments.SF_Calc.CompactUp
REM -----------------------------------------------------------------------------
Public Function CopySheet(Optional ByVal SheetName As Variant _
, Optional ByVal NewName As Variant _
, Optional ByVal BeforeSheet As Variant _
) As Boolean
''' Copy a specified sheet before an existing sheet or at the end of the list of sheets
''' The sheet to copy may be inside any open Calc document
''' Args:
''' SheetName: The name of the sheet to copy or its reference
''' NewName: Must not exist
''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert
''' Returns:
''' True if the sheet could be copied successfully
''' Exceptions:
''' DUPLICATESHEETERROR A sheet with the given name exists already
''' Examples:
''' oDoc.CopySheet("SheetX", "SheetY")
''' ' Copy within the same document
''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True)
''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods")
''' oDocB.CopySheet(oDocA.Sheet("SheetX"), "SheetY")
''' ' Copy from 1 file to another and put the new sheet at the end
Dim bCopy As Boolean ' Return value
Dim oSheets As Object ' com.sun.star.sheet.XSpreadsheets
Dim vSheets As Variant ' List of existing sheets
Dim lSheetIndex As Long ' Index of a sheet
Dim oSheet As Object ' Alias of SheetName as reference
Dim lRandom As Long ' Output of random number generator
Dim sRandom ' Random sheet name
Const cstThisSub = "SFDocuments.Calc.CopySheet"
Const cstSubArgs = "SheetName, NewName, [BeforeSheet=""""]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
bCopy = False
Check:
If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive(True) Then GoTo Finally
If Not _ValidateSheet(SheetName, "SheetName", , True, , , True) Then GoTo Finally
If Not _ValidateSheet(NewName, "NewName", True) Then GoTo Finally
If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally
End If
Try:
' Determine the index of the sheet before which to insert the copy
Set oSheets = _Component.getSheets
vSheets = oSheets.getElementNames()
If VarType(BeforeSheet) = V_STRING Then
lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet)
Else
lSheetIndex = BeforeSheet - 1
If lSheetIndex < 0 Then lSheetIndex = 0
If lSheetIndex > UBound(vSheets) Then lSheetIndex = UBound(vSheets) + 1
End If
' Copy sheet inside the same document OR import from another document
If VarType(SheetName) = V_STRING Then
_Component.getSheets.copyByName(SheetName, NewName, lSheetIndex)
Else
Set oSheet = SheetName
With oSheet
' If a sheet with same name as input exists in the target sheet, rename it first with a random name
sRandom = ""
If ScriptForge.SF_Array.Contains(vSheets, .SheetName) Then
lRandom = ScriptForge.SF_Session.ExecuteCalcFunction("RANDBETWEEN.NV", 1, 9999999)
sRandom = "SF_" & Right("0000000" & lRandom, 7)
oSheets.getByName(.SheetName).setName(sRandom)
End If
' Import i.o. Copy
oSheets.importSheet(oSheet.Component, .SheetName, lSheetIndex)
' Rename to new sheet name
oSheets.getByName(.SheetName).setName(NewName)
' Reset random name
If Len(sRandom) > 0 Then oSheets.getByName(sRandom).setName(.SheetName)
End With
End If
bCopy = True
Finally:
CopySheet = bCopy
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
CatchDuplicate:
ScriptForge.SF_Exception.RaiseFatal(DUPLICATESHEETERROR, "NewName", NewName, "Document", [_Super]._FileIdent())
GoTo Finally
End Function ' SFDocuments.SF_Calc.CopySheet
REM -----------------------------------------------------------------------------
Public Function CopySheetFromFile(Optional ByVal FileName As Variant _
, Optional ByVal SheetName As Variant _
, Optional ByVal NewName As Variant _
, Optional ByVal BeforeSheet As Variant _
) As Boolean
''' Copy a specified sheet before an existing sheet or at the end of the list of sheets
''' The sheet to copy is located inside any closed Calc document
''' Args:
''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation
''' The file must not be protected with a password
''' SheetName: The name of the sheet to copy
''' NewName: Must not exist
''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert
''' Returns:
''' True if the sheet could be created
''' The created sheet is blank when the input file is not a Calc file
''' The created sheet contains an error message when the input sheet was not found
''' Exceptions:
''' DUPLICATESHEETERROR A sheet with the given name exists already
''' UNKNOWNFILEERROR The input file is unknown
''' Examples:
''' oDoc.CopySheetFromFile("C:\MyFile.ods", "SheetX", "SheetY", 3)
Dim bCopy As Boolean ' Return value
Dim oSheet As Object ' com.sun.star.sheet.XSpreadsheet
Dim sFileName As String ' URL alias of FileName
Dim FSO As Object ' SF_FileSystem
Const cstThisSub = "SFDocuments.Calc.CopySheetFromFile"
Const cstSubArgs = "FileName, SheetName, NewName, [BeforeSheet=""""]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
bCopy = False
Check:
If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not _IsStillAlive(True) Then GoTo Finally
If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(SheetName, "SheetName", V_STRING) Then GoTo Finally
If Not _ValidateSheet(NewName, "NewName", True) Then GoTo Finally
If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally
End If
Try:
Set FSO = ScriptForge.SF_FileSystem
' Does the input file exist ?
If Not FSO.FileExists(FileName) Then GoTo CatchNotExists
sFileName = FSO._ConvertToUrl(FileName)
' Insert a blank new sheet and import sheet from file via link setting and deletion
If Not InsertSheet(Newname, BeforeSheet) Then GoTo Finally
Set oSheet = _Component.getSheets.getByName(NewName)
With oSheet
.link(sFileName,SheetName, "", "", com.sun.star.sheet.SheetLinkMode.NORMAL)
.LinkMode = com.sun.star.sheet.SheetLinkMode.NONE
.LinkURL = ""
End With
bCopy = True
Finally:
CopySheetFromFile = bCopy
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
CatchNotExists:
ScriptForge.SF_Exception.RaiseFatal(UNKNOWNFILEERROR, "FileName", FileName)
GoTo Finally
End Function ' SFDocuments.SF_Calc.CopySheetFromFile
REM -----------------------------------------------------------------------------
Public Function CopyToCell(Optional ByVal SourceRange As Variant _
, Optional ByVal DestinationCell As Variant _
) As String
''' Copy a specified source range to a destination range or cell
''' The source range may belong to another open document
''' The method imitates the behaviour of a Copy/Paste from a range to a single cell
''' Args:
''' SourceRange: the source range as a string if it belongs to the same document
''' or as a reference if it belongs to another open Calc document
''' DestinationCell: the destination of the copied range of cells, as a string
''' If given as a range of cells, the destination will be reduced to its top-left cell
''' Returns:
''' A string representing the modified range of cells
''' The modified area depends only on the size of the source area
''' Examples:
''' oDoc.CopyToCell("SheetX.A1:F10", "SheetY.C5")
''' ' Copy within the same document
''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True)
''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods")
''' oDocB.CopyToCell(oDocA.Range("SheetX.A1:F10"), "SheetY.C5")
''' ' Copy from 1 file to another
Dim sCopy As String ' Return value
Dim oSource As Object ' Alias of SourceRange to avoid "Object variable not set" run-time error
Dim oSourceAddress As Object ' com.sun.star.table.CellRangeAddress
Dim oDestRange As Object ' Destination as a range
Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress
Dim oDestCell As Object ' com.sun.star.table.CellAddress
Dim oSelect As Object ' Current selection in source
Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable
Const cstThisSub = "SFDocuments.Calc.CopyToCell"
Const cstSubArgs = "SourceRange, DestinationCell"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
--> --------------------
--> maximum size reached
--> --------------------
[ zur Elbe Produktseite wechseln0.43Quellennavigators
Analyse erneut starten
]
|
2026-04-02
|