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 ''' ''' 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 500 ''' ''' 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 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 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 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 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 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) 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 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 sCopy = "" Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive(True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", Array(V_STRING, ScriptForge.V_OBJECT), , , CALCREFERENCE) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally End If Try: If VarType(SourceRange) = V_STRING Then ' Same document - Use UNO copyRange method Set oSourceAddress = _ParseAddress(SourceRange).XCellRange.RangeAddress Set oDestRange = _ParseAddress(DestinationCell) Set oDestAddress = oDestRange.XCellRange.RangeAddress Set oDestCell = New com.sun.star.table.CellAddress With oDestAddress oDestCell.Sheet = .Sheet oDestCell.Column = .StartColumn oDestCell.Row = .StartRow End With oDestRange.XSpreadsheet.copyRange(oDestCell, oSourceAddress) Else ' Use clipboard to copy - current selection in Source should be preserved Set oSource = SourceRange With oSource ' Keep current selection in source document Set oSelect = .Component.CurrentController.getSelection() ' Select, copy the source range and paste in the top-left cell of the destination .Component.CurrentController.select(.XCellRange) Set oClipboard = .Component.CurrentController.getTransferable() _Component.CurrentController.select(_Offset(DestinationCell, 0, 0, 1, 1).XCellRange) _Component.CurrentController.insertTransferable(oClipBoard) ' Restore previous selection in Source _RestoreSelections(.Component, oSelect) Set oSourceAddress = .XCellRange.RangeAddress End With End If With oSourceAddress sCopy = _Offset(DestinationCell, 0, 0, .EndRow - .StartRow + 1, .EndColumn - .StartColumn + 1).RangeName End With Finally: CopyToCell = sCopy ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.CopyToCell REM ----------------------------------------------------------------------------- Public Function CopyToRange(Optional ByVal SourceRange As Variant _ , Optional ByVal DestinationRange As Variant _ ) As String ''' Copy downwards and/or rightwards a specified source range to a destination range ''' The source range may belong to another open document ''' The method imitates the behaviour of a Copy/Paste from a range to a larger range ''' If the height (resp. width) of the destination area is > 1 row (resp. column) ''' then the height (resp. width) of the source must be <= the height (resp. width) ''' of the destination. Otherwise nothing happens ''' If the height (resp.width) of the destination is = 1 then the destination ''' is expanded downwards (resp. rightwards) up to the height (resp. width) ''' of the source range ''' 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 ''' DestinationRange: the destination of the copied range of cells, as a string ''' Returns: ''' A string representing the modified range of cells ''' Examples: ''' oDoc.CopyToRange("SheetX.A1:F10", "SheetY.C5:J5") ''' ' Copy within the same document ''' ' Returned range: $SheetY.$C$5:$J$14 ''' 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.CopyToRange(oDocA.Range("SheetX.A1:F10"), "SheetY.C5:J5") ''' ' 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 oDestRange As Object ' Destination as a range 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 Dim bSameDocument As Boolean ' True when source in same document as destination Dim lHeight As Long ' Height of destination Dim lWidth As Long ' Width of destination Const cstThisSub = "SFDocuments.Calc.CopyToRange" Const cstSubArgs = "SourceRange, DestinationRange" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sCopy = "" Check:string If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive(True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", Array(V_STRING, ScriptForge.V_OBJECT), , , CALCREFERENCE) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(DestinationRange, "DestinationRange", V_STRING) Then GoTo Finally End If Try: ' Copy done via clipboard ' Check Height/Width destination = 1 or > Height/Width of source bSameDocument = ( VarType(SourceRange) = V_STRING ) If bSameDocument Then Set oSource = _ParseAddress(SourceRange) Else Set oSource = SourceRange Set oDestRange = _ParseAddress(DestinationRange) With oDestRange lHeight = .Height lWidth = .Width If lHeight = 1 Then lHeight = oSource.Height ' Future height ElseIf lHeight < oSource.Height Then GoTo Finally End If If lWidth = 1 Then lWidth = oSource.Width ' Future width ElseIf lWidth < oSource.Width Then GoTo Finally End If End With With oSource ' Store actual selection in source Set oSelect = .Component.CurrentController.getSelection() ' Select, copy the source range and paste in the destination .Component.CurrentController.select(.XCellRange) Set oClipboard = .Component.CurrentController.getTransferable() _Component.CurrentController.select(oDestRange.XCellRange) _Component.CurrentController.insertTransferable(oClipBoard) ' Restore selection in source _RestoreSelections(.Component, oSelect) End With sCopy = _Offset(oDestRange, 0, 0, lHeight, lWidth).RangeName Finally: CopyToRange = sCopy ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.CopyToRange REM ----------------------------------------------------------------------------- Public Function CreateChart(Optional ByVal ChartName As Variant _ , Optional ByVal SheetName As Variant _ , Optional ByVal Range As Variant _ , Optional ColumnHeader As Variant _ , Optional RowHeader As Variant _ ) As Variant ''' Return a new chart instance initialized with default values ''' Args: ''' ChartName: The user-defined name of the new chart ''' SheetName: The name of an existing sheet ''' Range: the cell or the range as a string that should be drawn ''' ColumnHeader: when True, the topmost row of the range will be used to set labels for the category axis or the legend. ''' Default = False ''' RowHeader: when True, the leftmost column of the range will be used to set labels for the category axis or the legend. ''' Default = False ''' Returns: ''' A new chart service instance ''' Exceptions: ''' DUPLICATECHARTERROR A chart with the same name exists already in the given sheet ''' Examples: ''' Dim oChart As Object ''' Set oChart = oDoc.CreateChart("myChart", "SheetX", "A1:C8", ColumnHeader := True) Dim oChart As Object ' Return value Dim vCharts As Variant ' List of pre-existing charts Dim oSheet As Object ' Alias of SheetName as reference Dim oRange As Object ' Alias of Range Dim oRectangle as new com.sun.star.awt.Rectangle ' Simple shape Const cstThisSub = "SFDocuments.Calc.CreateChart" Const cstSubArgs = "ChartName, SheetName, Range, [ColumnHeader=False], [RowHeader=False]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch Set oChart = Nothing Check: If IsMissing(RowHeader) Or IsEmpty(RowHeader) Then Rowheader = False If IsMissing(ColumnHeader) Or IsEmpty(ColumnHeader) Then ColumnHeader = False If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive(True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING) Then GoTo Finally If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(ColumnHeader, "ColumnHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(RowHeader, "RowHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally End If vCharts = Charts(SheetName) If ScriptForge.SF_Array.Contains(vCharts, ChartName, CaseSensitive := True) Then GoTo CatchDuplicate Try: ' The rectangular shape receives arbitrary values. User can Resize() it later With oRectangle .X = 0 : .Y = 0 .Width = 8000 : .Height = 6000 End With ' Initialize sheet and range Set oSheet = _Component.getSheets.getByName(SheetName) Set oRange = _ParseAddress(Range) ' Create the chart and get ihe corresponding chart instance oSheet.getCharts.addNewByName(ChartName, oRectangle, Array(oRange.XCellRange.RangeAddress), ColumnHeader, RowHeader) Set oChart = Charts(SheetName, ChartName) oChart._Shape.Name = ChartName ' Both user-defined and internal names match ChartName oChart._Diagram.Wall.FillColor = RGB(255, 255, 255) ' Align on background color set by the user interface by default Finally: Set CreateChart = oChart ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally CatchDuplicate: ScriptForge.SF_Exception.RaiseFatal(DUPLICATECHARTERROR, "ChartName", ChartName, "SheetName", SheetName, "Document", [_Super]._FileIdent()) GoTo Finally End Function ' SFDocuments.SF_Calc.CreateChart REM ----------------------------------------------------------------------------- Public Function CreatePivotTable(Optional ByVal PivotTableName As Variant _ , Optional ByVal SourceRange As Variant _ , Optional ByVal TargetCell As Variant _ , Optional ByRef DataFields As Variant _ , Optional ByRef RowFields As Variant _ , Optional ByRef ColumnFields As Variant _ , Optional ByVal FilterButton As Variant _ , Optional ByVal RowTotals As Variant _ , Optional ByVal ColumnTotals As Variant _ ) As String ''' Create a new pivot table with the properties defined by the arguments. ''' If a pivot table with the same name exists already in the targeted sheet, it will be erased without warning. ''' Args: ''' PivotTableName: The user-defined name of the new pivottable ''' SourceRange: The range as a string containing the raw data. ''' The first row of the range is presumed to contain the field names of the new pivot table ''' TargetCell: the top left cell or the range as a string where to locate the pivot table. ''' Only the top left cell of the range will be considered. ''' DataFields: A single string or an array of field name + function to apply, formatted like: ''' Array("FieldName[;Function]", ...) ''' The allowed functions are: Sum, Count, Average, Max, Min, Product, CountNums, StDev, StDevP, Var, VarP and Median. ''' The default function is: When the values are all numerical, Sum is used, otherwise Count ''' RowFields: A single string or an array of the field names heading the pivot table rows ''' ColumnFields: A single string or an array of the field names heading the pivot table columns ''' FilterButton: When True (default), display a "Filter" button above the pivot table ''' RowTotals: When True (default), display a separate column for row totals ''' ColumnTotals: When True (default), display a separate row for column totals ''' Returns: ''' Return the range where the new pivot table is deployed. ''' Examples: ''' Dim vData As Variant, oDoc As Object, sTable As String, sPivot As String ''' vData = Array(Array("Item", "State", "Team", "2002", "2003", "2004"), _ ''' Array("Books", "Michigan", "Jean", 14788, 30222, 23490), _ ''' Array("Candy", "Michigan", "Jean", 26388, 15641, 32849), _ ''' Array("Pens", "Michigan", "Jean", 16569, 32675, 25396), _ ''' Array("Books", "Michigan", "Volker", 21961, 21242, 29009), _ ''' Array("Candy", "Michigan", "Volker", 26142, 22407, 32841)) ''' Set oDoc = ui.CreateDocument("Calc") ''' sTable = oDoc.SetArray("A1", vData) ''' sPivot = oDoc.CreatePivotTable("PT1", sTable, "H1", Array("2002", "2003;count", "2004;average"), "Item", Array("State", "Team"), False) Dim sPivotTable As String ' Return value Dim vData As Variant ' Alias of DataFields Dim vRows As Variant ' Alias of RowFields Dim vColumns As Variant ' Alias of ColumnFields Dim oSourceAddress As Object ' Source as an _Address Dim oTargetAddress As Object ' Target as an _Address Dim vHeaders As Variant ' Array of header fields in the source range Dim oPivotTables As Object ' com.sun.star.sheet.XDataPilotTables Dim oDescriptor As Object ' com.sun.star.sheet.DataPilotDescriptor Dim oFields As Object ' ScDataPilotFieldsObj - Collection of fields Dim oField As Object ' ScDataPilotFieldsObj - A single field Dim sField As String ' A single field name Dim sData As String ' A single data field name + function Dim vDataField As Variant ' A single vData element, split on semicolon Dim sFunction As String ' Function to apply on a data field (string) Dim iFunction As Integer ' Equivalent of sFunction as com.sun.star.sheet.GeneralFunction2 constant Dim oOutputRange As Object ' com.sun.star.table.CellRangeAddress Dim i As Integer Const cstThisSub = "SFDocuments.Calc.CreatePivotTable" Const cstSubArgs = "PivotTableName, SourceRange, TargetCell, DataFields, [RowFields], [ColumnFields]" _ & ", [FilterButton=True], [RowTotals=True], [ColumnTotals=True]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sPivotTable = "" Check: If IsMissing(RowFields) Or IsEmpty(RowFields) Then RowFields = Array() If IsMissing(ColumnFields) Or IsEmpty(ColumnFields) Then ColumnFields = Array() If IsMissing(FilterButton) Or IsEmpty(FilterButton) Then FilterButton = True If IsMissing(RowTotals) Or IsEmpty(RowTotals) Then RowTotals = True If IsMissing(ColumnTotals) Or IsEmpty(ColumnTotals) Then ColumnTotals = True If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive(True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(PivotTableName, "PivotTableName", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(TargetCell, "TargetCell", V_STRING) Then GoTo Finally If IsArray(DataFields) Then If Not ScriptForge.SF_Utils._ValidateArray(DataFields, "DataFields", 1, V_STRING, True) Then GoTo Finally Else If Not ScriptForge.SF_Utils._Validate(DataFields, "DataFields", V_STRING) Then GoTo Finally End If If IsArray(RowFields) Then If Not ScriptForge.SF_Utils._ValidateArray(RowFields, "RowFields", 1, V_STRING, True) Then GoTo Finally Else If Not ScriptForge.SF_Utils._Validate(RowFields, "RowFields", V_STRING) Then GoTo Finally End If If IsArray(ColumnFields) Then If Not ScriptForge.SF_Utils._ValidateArray(ColumnFields, "ColumnFields", 1, V_STRING, True) Then GoTo Finally Else If Not ScriptForge.SF_Utils._Validate(ColumnFields, "ColumnFields", V_STRING) Then GoTo Finally End If If Not ScriptForge.SF_Utils._Validate(FilterButton, "FilterButton", ScriptForge.V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(RowTotals, "RowTotals", ScriptForge.V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(ColumnTotals, "ColumnTotals", ScriptForge.V_BOOLEAN) Then GoTo Finally End If ' Next statements must be outside previous If-block to force their execution even in case of internal call If IsArray(DataFields) Then vData = DataFields Else vData = Array(DataFields) If IsArray(RowFields) Then vRows = RowFields Else vRows = Array(RowFields) If IsArray(ColumnFields) Then vColumns = ColumnFields Else vColumns = Array(ColumnFields) Try: Set oSourceAddress = _ParseAddress(SourceRange) vHeaders = GetValue(Offset(SourceRange, 0, 0, 1)) ' Content of the first row of the source Set oTargetAddress = _Offset(TargetCell, 0, 0, 1, 1) ' Retain the top left cell only Set oPivotTables = oTargetAddress.XSpreadsheet.getDataPilotTables() ' Initialize new pivot table Set oDescriptor = oPivotTables.createDataPilotDescriptor() oDescriptor.setSourceRange(oSourceAddress.XCellRange.RangeAddress) Set oFields = oDescriptor.getDataPilotFields() ' Set row fields For i = 0 To UBound(vRows) sField = vRows(i) If Len(sField) > 0 Then If Not ScriptForge.SF_Utils._Validate(sField, "RowFields", V_STRING, vHeaders) Then GoTo Finally Set oField = oFields.getByName(sField) oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.ROW End If Next i ' Set column fields For i = 0 To UBound(vColumns) sField = vColumns(i) If Len(sField) > 0 Then If Not ScriptForge.SF_Utils._Validate(sField, "ColumnFields", V_STRING, vHeaders) Then GoTo Finally Set oField = oFields.getByName(sField) oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.COLUMN End If Next i ' Set data fields For i = 0 To UBound(vData) sData = vData(i) ' Minimal parsing If Right(sData, 1) = ";" Then sData = Left(sData, Len(sData) - 1) vDataField = Split(sData, ";") sField = vDataField(0) If UBound(vDataField) > 0 Then sFunction = vDataField(1) Else sFunction = "" ' Define field properties If Len(sField) > 0 Then If Not ScriptForge.SF_Utils._Validate(sField, "DataFields", V_STRING, vHeaders) Then GoTo Finally Set oField = oFields.getByName(sField) oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.DATA ' Associate the correct function With com.sun.star.sheet.GeneralFunction2 Select Case UCase(sFunction) Case "" : iFunction = .AUTO Case "SUM" : iFunction = .SUM Case "COUNT" : iFunction = .COUNT Case "AVERAGE" : iFunction = .AVERAGE Case "MAX" : iFunction = .MAX Case "MIN" : iFunction = .MIN Case "PRODUCT" : iFunction = .PRODUCT Case "COUNTNUMS": iFunction = .COUNTNUMS Case "STDEV" : iFunction = .STDEV Case "STDEVP" : iFunction = .STDEVP Case "VAR" : iFunction = .VAR Case "VARP" : iFunction = .VARP Case "MEDIAN" : iFunction = .MEDIAN Case Else If Not ScriptForge.SF_Utils._Validate(sFunction, "DataFields/Function", V_STRING _ , Array("Sum", "Count", "Average", "Max", "Min", "Product", "CountNums" _ , "StDev", "StDevP", "Var", "VarP", "Median") _ ) Then GoTo Finally End Select End With oField.Function2 = iFunction End If Next i ' Remove any pivot table with same name If oPivotTables.hasByName(PivotTableName) Then oPivotTables.removeByName(PivotTableName) ' Finalize the new pivot table oDescriptor.ShowFilterButton = FilterButton oDescriptor.RowGrand = RowTotals oDescriptor.ColumnGrand = ColumnTotals oPivotTables.insertNewByName(PivotTableName, oTargetAddress.XCellRange.getCellByPosition(0, 0).CellAddress, oDescriptor) ' Determine the range of the new pivot table Set oOutputRange = oPivotTables.getByName(PivotTableName).OutputRange With oOutputRange sPivotTable = _Component.getSheets().getCellRangeByPosition(.StartColumn, .StartRow, .EndColumn, .EndRow, .Sheet).AbsoluteName End With Finally: CreatePivotTable = sPivotTable ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.CreatePivotTable REM ----------------------------------------------------------------------------- Public Function DAvg(Optional ByVal Range As Variant) As Double ''' Get the average of the numeric values stored in the given range ''' Args: ''' Range : the range as a string where to get the values from ''' Returns: ''' The average of the numeric values as a double ''' Examples: ''' Val = oDoc.DAvg("~.A1:A1000") Try: DAvg = _DFunction("DAvg", Range) Finally: Exit Function End Function ' SFDocuments.SF_Calc.DAvg REM ----------------------------------------------------------------------------- Public Function DCount(Optional ByVal Range As Variant) As Long ''' Get the number of numeric values stored in the given range ''' Args: ''' Range : the range as a string where to get the values from ''' Returns: ''' The number of numeric values as a Long ''' Examples: ''' Val = oDoc.DCount("~.A1:A1000") Try: DCount = _DFunction("DCount", Range) Finally: Exit Function End Function ' SFDocuments.SF_Calc.DCount REM ----------------------------------------------------------------------------- Public Function DMax(Optional ByVal Range As Variant) As Double ''' Get the greatest of the numeric values stored in the given range ''' Args: ''' Range : the range as a string where to get the values from ''' Returns: ''' The greatest of the numeric values as a double ''' Examples: ''' Val = oDoc.DMax("~.A1:A1000") Try: DMax = _DFunction("DMax", Range) Finally: Exit Function End Function ' SFDocuments.SF_Calc.DMax REM ----------------------------------------------------------------------------- Public Function DMin(Optional ByVal Range As Variant) As Double ''' Get the smallest of the numeric values stored in the given range ''' Args: ''' Range : the range as a string where to get the values from ''' Returns: ''' The smallest of the numeric values as a double ''' Examples: ''' Val = oDoc.DMin("~.A1:A1000") Try: DMin = _DFunction("DMin", Range) Finally: Exit Function End Function ' SFDocuments.SF_Calc.DMin REM ----------------------------------------------------------------------------- Public Function DSum(Optional ByVal Range As Variant) As Double ''' Get sum of the numeric values stored in the given range ''' Args: ''' Range : the range as a string where to get the values from ''' Returns: ''' The sum of the numeric values as a double ''' Examples: ''' Val = oDoc.DSum("~.A1:A1000") Try: DSum = _DFunction("DSum", Range) Finally: Exit Function End Function ' SFDocuments.SF_Calc.DSum REM ----------------------------------------------------------------------------- Public Function ExportRangeToFile(Optional ByVal Range As Variant _ , Optional ByVal FileName As Variant _ , Optional ByVal ImageType As Variant _ , Optional ByVal Overwrite As Variant _ ) As Boolean ''' Store the given range as an image to the given file location ''' Actual selections are not impacted ''' Inspired by https://stackoverflow.com/questions/30509532/how-to-export-cell-range-to-pdf-file ''' Args: ''' Range: sheet name or cell range to be exported, as a string ''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation ''' ImageType: the name of the targeted media type ''' Allowed values: jpeg, pdf (default) and png ''' Overwrite: True if the destination file may be overwritten (default = False) ''' Returns: ''' False if the document could not be saved ''' Exceptions: ''' RANGEEXPORTERROR The destination has its readonly attribute set or overwriting rejected ''' Examples: ''' oDoc.ExportRangeToFile('SheetX.B2:J15", "C:\Me\Range2.png", ImageType := "png", Overwrite := True) Dim bSaved As Boolean ' return value Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess Dim sFile As String ' Alias of FileName Dim vStoreArguments As Variant ' Array of com.sun.star.beans.PropertyValue Dim vFilterData As Variant ' Array of com.sun.star.beans.PropertyValue Dim FSO As Object ' SF_FileSystem Dim vImageTypes As Variant ' Array of permitted image types Dim vFilters As Variant ' Array of corresponding filters in the same order as vImageTypes Dim sFilter As String ' The filter to apply Dim oSelect As Object ' Currently selected range(s) Dim oAddress As Object ' Alias of Range Const cstImageTypes = "jpeg,pdf,png" Const cstFilters = "calc_jpg_Export,calc_pdf_Export,calc_png_Export" Const cstThisSub = "SFDocuments.Calc.ExportRangeToFile" Const cstSubArgs = "Range, FileName, [ImageType=""pdf""|""jpeg""|""png""], [Overwrite=False]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError bSaved = False Check: If IsMissing(ImageType) Or IsEmpty(ImageType) Then ImageType = "pdf" If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False vImageTypes = Split(cstImageTypes, ",") If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(ImageType, "ImageType", V_STRING, vImageTypes) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally End If ' Check destination file overwriting Set FSO = CreateScriptService("FileSystem") sFile = FSO._ConvertToUrl(FileName) If FSO.FileExists(FileName) Then If Overwrite = False Then GoTo CatchError Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess") If oSfa.isReadonly(sFile) Then GoTo CatchError End If Try: ' Setup arguments vFilters = Split(cstFilters, ",") sFilter = vFilters(ScriptForge.SF_Array.IndexOf(vImageTypes, ImageType, CaseSensitive := False)) Set oAddress = _ParseAddress(Range) ' The filter arguments differ between ' 1) pdf : store range in Selection property value ' 2) png, jpeg : save current selection, select range, restore initial selection If LCase(ImageType) = "pdf" Then vFilterData = Array(ScriptForge.SF_Utils._MakePropertyValue("Selection", oAddress.XCellRange) ) vStoreArguments = Array( _ ScriptForge.SF_Utils._MakePropertyValue("FilterName", sFilter) _ , ScriptForge.SF_Utils._MakePropertyValue("FilterData", vFilterData) _ ) Else ' png, jpeg ' Save the current selection(s) Set oSelect = _Component.CurrentController.getSelection() _Component.CurrentController.select(oAddress.XCellRange) vStoreArguments = Array( _ ScriptForge.SF_Utils._MakePropertyValue("FilterName", sFilter) _ , ScriptForge.SF_Utils._MakePropertyValue("SelectionOnly", True) _ ) End If ' Apply the filter and export _Component.storeToUrl(sFile, vStoreArguments) If LCase(ImageType) <> "pdf" Then _RestoreSelections(_Component, oSelect) bSaved = True Finally: ExportRangeToFile = bSaved ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally CatchError: ScriptForge.SF_Exception.RaiseFatal(RANGEEXPORTERROR, "FileName", FileName, "Overwrite", Overwrite) GoTo Finally End Function ' SFDocuments.SF_Chart.ExportRangeToFile REM ----------------------------------------------------------------------------- Public Function Forms(Optional ByVal SheetName As Variant _ , Optional ByVal Form As Variant _ ) As Variant ''' Return either ''' - the list of the Forms contained in the given sheet ''' - a SFDocuments.Form object based on its name or its index ''' Args: ''' SheetName: the name of the sheet containing the requested form or forms ''' Form: a form stored in the document given by its name or its index ''' When absent, the list of available forms is returned ''' To get the first (unique ?) form stored in the form document, set Form = 0 ''' Exceptions: ''' CALCFORMNOTFOUNDERROR Form not found ''' Returns: ''' A zero-based array of strings if Form is absent ''' An instance of the SF_Form class if Form exists ''' Example: ''' Dim myForm As Object, myList As Variant ''' myList = oDoc.Forms("ThisSheet") ''' Set myForm = oDoc.Forms("ThisSheet", 0) Dim oForm As Object ' The new Form class instance Dim oMainForm As Object ' com.sun.star.comp.sdb.Content Dim oXForm As Object ' com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm Dim vFormNames As Variant ' Array of form names Dim oForms As Object ' Forms collection Const cstDrawPage = -1 ' There is no DrawPages collection in Calc sheets Const cstThisSub = "SFDocuments.Calc.Forms" Const cstSubArgs = "SheetName, [Form=""""]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch Check: If IsMissing(Form) Or IsEmpty(Form) Then Form = "" If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Form, "Form", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally End If Try: ' Start from the Calc sheet and go down to forms Set oForms = _Component.getSheets.getByName(SheetName).DrawPage.Forms vFormNames = oForms.getElementNames() If Len(Form) = 0 Then ' Return the list of valid form names Forms = vFormNames Else If VarType(Form) = V_STRING Then ' Find the form by name If Not ScriptForge.SF_Utils._Validate(Form, "Form", V_STRING, vFormNames) Then GoTo Finally Set oXForm = oForms.getByName(Form) Else ' Find the form by index If Form < 0 Or Form >= oForms.Count Then GoTo CatchNotFound Set oXForm = oForms.getByIndex(Form) End If ' Create the new Form class instance Set oForm = SF_Register._NewForm(oXForm) With oForm Set .[_Parent] = [Me] ._SheetName = SheetName ._FormType = ISCALCFORM Set ._Component = _Component ._Initialize() End With Set Forms = oForm End If Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally CatchNotFound: ScriptForge.SF_Exception.RaiseFatal(CALCFORMNOTFOUNDERROR, Form, _FileIdent()) End Function ' SFDocuments.SF_Calc.Forms REM ----------------------------------------------------------------------------- Function GetColumnName(Optional ByVal ColumnNumber As Variant) As String ''' Convert a column number (range 1, 2,..1024) into its letter counterpart (range 'A', 'B',..'AMJ'). ''' Args: ''' ColumnNumber: the column number, must be in the interval 1 ... 1024 ''' Returns: ''' a string representation of the column name, in range 'A'..'AMJ' ''' If ColumnNumber is not in the allowed range, returns a zero-length string ''' Example: ''' MsgBox oDoc.GetColumnName(1022) ' "AMH" ''' Adapted from a Python function by sundar nataraj ''' http://stackoverflow.com/questions/23861680/convert-spreadsheet-number-to-column-letter Dim sCol As String ' Return value Const cstThisSub = "SFDocuments.Calc.GetColumnName" Const cstSubArgs = "ColumnNumber" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sCol = "" Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not SF_Utils._Validate(ColumnNumber, "ColumnNumber", V_NUMERIC) Then GoTo Finally End If Try: If (ColumnNumber > 0) And (ColumnNumber <= MAXCOLS) Then sCol = _GetColumnName(ColumnNumber) Finally: GetColumnName = sCol ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.GetColumnName REM ----------------------------------------------------------------------------- Public Function GetFormula(Optional ByVal Range As Variant) As Variant ''' Get the formula(e) stored in the given range of cells ''' Args: ''' Range : the range as a string where to get the formula from ''' Returns: ''' A scalar, a zero-based 1D array or a zero-based 2D array of strings ''' Examples: ''' Val = oDoc.GetFormula("~.A1:A1000") Dim vGet As Variant ' Return value Dim oAddress As Object ' Alias of Range Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property Const cstThisSub = "SFDocuments.Calc.GetFormula" Const cstSubArgs = "Range" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch vGet = Empty Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally End If Try: ' Get the data Set oAddress = _ParseAddress(Range) vDataArray = oAddress.XCellRange.getFormulaArray() ' Convert the data array to scalar, vector or array vGet = _ConvertFromDataArray(vDataArray) Finally: GetFormula = vGet ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.GetFormula REM ----------------------------------------------------------------------------- Public Function GetProperty(Optional ByVal PropertyName As Variant _ , Optional ObjectName As Variant _ ) As Variant ''' Return the actual value of the given property ''' Args: ''' PropertyName: the name of the property as a string ''' ObjectName: a sheet or range name ''' Returns: ''' The actual value of the property ''' Exceptions: ''' ARGUMENTERROR The property does not exist Const cstThisSub = "SFDocuments.Calc.GetProperty" Const cstSubArgs = "" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch GetProperty = Null Check: If IsMissing(ObjectName) Or IsEMpty(ObjectName) Then ObjectName = "" If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch If Not ScriptForge.SF_Utils._Validate(ObjectName, "ObjectName", V_STRING) Then GoTo Catch End If Try: ' Superclass or subclass property ? If ScriptForge.SF_Array.Contains([_Super].Properties(), PropertyName) Then GetProperty = [_Super].GetProperty(PropertyName) ElseIf Len(ObjectName) = 0 Then GetProperty = _PropertyGet(PropertyName) Else GetProperty = _PropertyGet(PropertyName, ObjectName) End If Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.GetProperty REM ----------------------------------------------------------------------------- Public Function GetValue(Optional ByVal Range As Variant) As Variant ''' Get the value(s) stored in the given range of cells ''' Args: ''' Range : the range as a string where to get the value from ''' Returns: ''' A scalar, a zero-based 1D array or a zero-based 2D array of strings and doubles ''' To convert doubles to dates, use the CDate builtin function ''' Examples: ''' Val = oDoc.GetValue("~.A1:A1000") Dim vGet As Variant ' Return value Dim oAddress As Object ' Alias of Range Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property Const cstThisSub = "SFDocuments.Calc.GetValue" Const cstSubArgs = "Range" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch vGet = Empty Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally End If Try: ' Get the data Set oAddress = _ParseAddress(Range) vDataArray = oAddress.XCellRange.getDataArray() ' Convert the data array to scalar, vector or array vGet = _ConvertFromDataArray(vDataArray) Finally: GetValue = vGet ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.GetValue REM ----------------------------------------------------------------------------- Public Function ImportFromCSVFile(Optional ByVal FileName As Variant _ , Optional ByVal DestinationCell As Variant _ , Optional ByVal FilterOptions As Variant _ ) As String ''' Import the content of a CSV-formatted text file starting from a given cell ''' Beforehand the destination area will be cleared from any content and format ''' Args: ''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation ''' DestinationCell: the destination of the copied range of cells, as a string ''' If given as range, the destination will be reduced to its top-left cell ''' FilterOptions: The arguments of the CSV input filter. ''' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#Filter_Options_for_the_CSV_Filter ''' Default: input file encoding is UTF8 ''' separator = comma, semi-colon or tabulation ''' string delimiter = double quote ''' all lines are included ''' quoted strings are formatted as texts ''' special numbers are detected ''' all columns are presumed texts ''' language = english/US => decimal separator is ".", thousands separator = "," ''' Returns: ''' A string representing the modified range of cells ''' The modified area depends only on the content of the source file ''' Exceptions: ''' DOCUMENTOPENERROR The csv file could not be opened ''' Examples: ''' oDoc.ImportFromCSVFile("C:\Temp\myCsvFile.csv", "SheetY.C5") Dim sImport As String ' Return value Dim oUI As Object ' UI service Dim oSource As Object ' New Calc document with csv loaded Dim oSelect As Object ' Current selection in destination Const cstFilter = "Text - txt - csv (StarCalc)" Const cstFilterOptions = "9/44/59/MRG,34,76,1,,1033,true,true" Const cstThisSub = "SFDocuments.Calc.ImportFromCSVFile" Const cstSubArgs = "FileName, DestinationCell, [FilterOptions]=""9/44/59/MRG,34,76,1,,1033,true,true""" ' If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sImport = "" Check: If IsMissing(FilterOptions) Or IsEmpty(FilterOptions) Then FilterOptions = cstFilterOptions 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(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally End If Try: ' Input file is loaded in an empty worksheet. Data are copied to destination cell Set oUI = CreateScriptService("UI") Set oSource = oUI.OpenDocument(FileName _ , ReadOnly := True _ , Hidden := True _ , FilterName := cstFilter _ , FilterOptions := FilterOptions _ ) ' Remember current selection and restore it after copy Set oSelect = _Component.CurrentController.getSelection() sImport = CopyToCell(oSource.Range("*"), DestinationCell) _RestoreSelections(_Component, oSelect) Finally: If Not IsNull(oSource) Then oSource.CloseDocument(False) ImportFromCSVFile = sImport ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.ImportFromCSVFile REM ----------------------------------------------------------------------------- Public Sub ImportFromDatabase(Optional ByVal FileName As Variant _ , Optional ByVal RegistrationName As Variant _ , Optional ByVal DestinationCell As Variant _ , Optional ByVal SQLCommand As Variant _ , Optional ByVal DirectSQL As Variant _ ) ''' Import the content of a database table, query or resultset, i.e. the result of a SELECT SQL command, ''' starting from a given cell ''' Beforehand the destination area will be cleared from any content and format ''' The modified area depends only on the content of the source data ''' Args: ''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation ''' RegistrationName: the name of a registered database ''' It is ignored if FileName <> "" ''' 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 ''' SQLCommand: either a table or query name (without square brackets) ''' or a full SQL commands where table and fieldnames are preferably surrounded with square brackets ''' Returns: ''' Implemented as a Sub because the doImport UNO method does not return any error ''' Exceptions: ''' BASEDOCUMENTOPENERROR The database file could not be opened ''' Examples: ''' oDoc.ImportFromDatabase("C:\Temp\myDbFile.odb", , "SheetY.C5", "SELECT * FROM [Employees] ORDER BY [LastName]") Dim oDBContext As Object ' com.sun.star.sdb.DatabaseContext Dim oDatabase As Object ' SFDatabases.Database service Dim lCommandType As Long ' A com.sun.star.sheet.DataImportMode.xxx constant Dim oQuery As Object ' com.sun.star.ucb.XContent Dim bDirect As Boolean ' Alias of DirectSQL 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.XCell Dim oSelect As Object ' Current selection in destination Dim vImportOptions As Variant ' Array of PropertyValues Const cstThisSub = "SFDocuments.Calc.ImportFromDatabase" Const cstSubArgs = "[FileName=""""], [RegistrationName=""""], DestinationCell, SQLCommand, [DirectSQL=False]" ' If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch Check: If IsMissing(FileName) Or IsEmpty(FileName) Then FileName = "" If IsMissing(RegistrationName) Or IsEmpty(RegistrationName) Then RegistrationName = "" If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive(True) Then GoTo Finally If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName", , True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally End If ' Check the existence of FileName If Len(FileName) = 0 Then ' FileName has precedence over RegistrationName If Len(RegistrationName) = 0 Then GoTo CatchError Set oDBContext = ScriptForge.SF_Utils._GetUNOService("DatabaseContext") If Not oDBContext.hasRegisteredDatabase(RegistrationName) Then GoTo CatchError FileName = ScriptForge.SF_FileSystem._ConvertFromUrl(oDBContext.getDatabaseLocation(RegistrationName)) End If If Not ScriptForge.SF_FileSystem.FileExists(FileName) Then GoTo CatchError Try: ' Check command type Set oDatabase = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Database", FileName, , True) ' Read-only If IsNull(oDatabase) Then GoTo CatchError With oDatabase If ScriptForge.SF_Array.Contains(.Tables, SQLCommand) Then bDirect = True lCommandType = com.sun.star.sheet.DataImportMode.TABLE ElseIf ScriptForge.SF_Array.Contains(.Queries, SQLCommand) Then Set oQuery = .XConnection.Queries.getByName(SQLCommand) bDirect = Not oQuery.EscapeProcessing lCommandType = com.sun.star.sheet.DataImportMode.QUERY Else bDirect = DirectSQL lCommandType = com.sun.star.sheet.DataImportMode.SQL SQLCommand = ._ReplaceSquareBrackets(SQLCommand) End If .CloseDatabase() Set oDatabase = oDatabase.Dispose() End With ' Determine the destination cell as the top-left coordinates of the given range Set oDestRange = _ParseAddress(DestinationCell) Set oDestAddress = oDestRange.XCellRange.RangeAddress Set oDestCell = oDestRange.XSpreadsheet.getCellByPosition(oDestAddress.StartColumn, oDestAddress.StartRow) ' Remember current selection Set oSelect = _Component.CurrentController.getSelection() ' Import arguments vImportOptions = Array(_ ScriptForge.SF_Utils._MakePropertyValue("DatabaseName", ScriptForge.SF_FileSystem._ConvertToUrl(FileName)) _ , ScriptForge.SF_Utils._MakePropertyValue("SourceObject", SQLCommand) _ , ScriptForge.SF_Utils._MakePropertyValue("SourceType", lCommandType) _ , ScriptForge.SF_Utils._MakePropertyValue("IsNative", bDirect) _ ) oDestCell.doImport(vImportOptions) ' Restore selection after import_ _RestoreSelections(_Component, oSelect) Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Sub Catch: GoTo Finally CatchError: SF_Exception.RaiseFatal(BASEDOCUMENTOPENERROR, "FileName", FileName, "RegistrationName", RegistrationName) GoTo Finally End Sub ' SFDocuments.SF_Calc.ImportFromDatabase REM ----------------------------------------------------------------------------- Public Function InsertSheet(Optional ByVal SheetName As Variant _ , Optional ByVal BeforeSheet As Variant _ ) As Boolean ''' Insert a new empty sheet before an existing sheet or at the end of the list of sheets ''' Args: ''' SheetName: The name of the new sheet ''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert ''' Returns: ''' True if the sheet could be inserted successfully ''' Examples: ''' oDoc.InsertSheet("SheetX", "SheetY") Dim bInsert As Boolean ' Return value Dim vSheets As Variant ' List of existing sheets Dim lSheetIndex As Long ' Index of a sheet Const cstThisSub = "SFDocuments.Calc.InsertSheet" Const cstSubArgs = "SheetName, [BeforeSheet=""""]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bInsert = 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) Then GoTo Finally If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally End If vSheets = _Component.getSheets.getElementNames() Try: 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 _Component.getSheets.insertNewByName(SheetName, lSheetIndex) bInsert = True Finally: InsertSheet = binsert ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.InsertSheet REM ----------------------------------------------------------------------------- Public Function Methods() As Variant ''' Return the list of public methods of the Calc service as an array Methods = Array( _ "A1Style" _ , "Charts" _ , "ClearAll" _ , "ClearFormats" _ , "ClearValues" _ , "CopySheet" _ , "CopySheetFromFile" _ , "CopyToCell" _ , "CopyToRange" _ , "CreateChart" _ , "DAvg" _ , "DCount" _ , "DMax" _ , "DMin" _ , "DSum" _ , "ExportRangeToFile" _ , "GetColumnName" _ , "GetFormula" _ , "GetValue" _ , "ImportFromCSVFile" _ , "ImportFromDatabase" _ , "InsertSheet" _ , "MoveRange" _ , "MoveSheet" _ , "Offset" _ , "OpenRangeSelector" _ , "Printf" _ , "PrintOut" _ , "RemoveDuplicates" _ , "RemoveSheet" _ , "RenameSheet" _ , "SetArray" _ , "SetCellStyle" _ , "SetFormula" _ , "SetValue" _ , "ShiftDown" _ , "ShiftLeft" _ , "ShiftRight" _ , "ShiftUp" _ , "SortRange" _ ) End Function ' SFDocuments.SF_Calc.Methods REM ----------------------------------------------------------------------------- Public Function MoveRange(Optional ByVal Source As Variant _ , Optional ByVal Destination As Variant _ ) As String ''' Move a specified source range to a destination range ''' Args: ''' Source: the source range of cells as a string ''' Destination: the destination of the moved 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.MoveRange("SheetX.A1:F10", "SheetY.C5") Dim sMove As String ' Return value Dim oSource As Object ' Alias of Source 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 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.MoveRange" Const cstSubArgs = "Source, Destination" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sMove = "" Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive(True) Then GoTo Finally If Not _Validate(Source, "Source", V_STRING) Then GoTo Finally If Not _Validate(Destination, "Destination", V_STRING) Then GoTo Finally End If Try: Set oSourceAddress = _ParseAddress(Source).XCellRange.RangeAddress Set oDestRange = _ParseAddress(Destination) Set oDestAddress = oDestRange.XCellRange.RangeAddress Set oDestCell = New com.sun.star.table.CellAddress With oDestAddress oDestCell.Sheet = .Sheet oDestCell.Column = .StartColumn oDestCell.Row = .StartRow End With oDestRange.XSpreadsheet.moveRange(oDestCell, oSourceAddress) With oSourceAddress sMove = _Offset(Destination, 0, 0, .EndRow - .StartRow + 1, .EndColumn - .StartColumn + 1).RangeName End With Finally: MoveRange = sMove ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.MoveRange REM ----------------------------------------------------------------------------- Public Function MoveSheet(Optional ByVal SheetName As Variant _ , Optional ByVal BeforeSheet As Variant _ ) As Boolean ''' Move a sheet before an existing sheet or at the end of the list of sheets ''' Args: ''' SheetName: The name of the sheet to move ''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to move the sheet ''' Returns: ''' True if the sheet could be moved successfully ''' Examples: ''' oDoc.MoveSheet("SheetX", "SheetY") Dim bMove As Boolean ' Return value Dim vSheets As Variant ' List of existing sheets Dim lSheetIndex As Long ' Index of a sheet Const cstThisSub = "SFDocuments.Calc.MoveSheet" Const cstSubArgs = "SheetName, [BeforeSheet=""""]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bMove = 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) Then GoTo Finally If Not _ValidateSheet(BeforeSheet, "BeforeSheet", , True, , True) Then GoTo Finally End If vSheets = _Component.getSheets.getElementNames() Try: 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 _Component.getSheets.MoveByName(SheetName, lSheetIndex) bMove = True Finally: MoveSheet = bMove ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.MoveSheet REM ----------------------------------------------------------------------------- Public Function Offset(Optional ByRef Range As Variant _ , Optional ByVal Rows As Variant _ , Optional ByVal Columns As Variant _ , Optional ByVal Height As Variant _ , Optional ByVal Width As Variant _ ) As String ''' Returns a new range offset by a certain number of rows and columns from a given range ''' Args: ''' Range : the range, as a string, from which the function searches for the new range ''' Rows : the number of rows by which the reference was corrected up (negative value) or down. ''' Use 0 (default) to stay in the same row. ''' Columns : the number of columns by which the reference was corrected to the left (negative value) or to the right. ''' Use 0 (default) to stay in the same column ''' Height : the vertical height for an area that starts at the new reference position. ''' Default = no vertical resizing ''' Width : the horizontal width for an area that starts at the new reference position. ''' Default - no horizontal resizing ''' Arguments Rows and Columns must not lead to zero or negative start row or column. ''' Arguments Height and Width must not lead to zero or negative count of rows or columns. ''' Returns: ''' A new range as a string ''' Exceptions: ''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries ''' Examples: ''' oDoc.Offset("A1", 2, 2) ' "'SheetX'.$C$3" (A1 moved by two rows and two columns down) ''' oDoc.Offset("A1", 2, 2, 5, 6) ' "'SheetX'.$C$3:$H$7" Dim sOffset As String ' Return value Dim oAddress As Object ' Alias of Range Const cstThisSub = "SFDocuments.Calc.Offset" Const cstSubArgs = "Range, [Rows=0], [Columns=0], [Height], [Width]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sOffset = "" Check: If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0 If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0 If IsMissing(Height) Or IsEmpty(Height) Then Height = 0 If IsMissing(Width) Or IsEmpty(Width) Then Width = 0 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Height, "Height", ScriptForge.V_NUMERIC) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Width, "Width", ScriptForge.V_NUMERIC) Then GoTo Finally End If Try: ' Define the new range string Set oAddress = _Offset(Range, Rows, Columns, Height, Width) sOffset = oAddress.RangeName Finally: Offset = sOffset ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.Offset REM ----------------------------------------------------------------------------- Public Function OpenRangeSelector(Optional ByVal Title As Variant _ , Optional ByVal Selection As Variant _ , Optional ByVal SingleCell As Variant _ , Optional ByVal CloseAfterSelect As Variant _ ) As String ''' Activates the Calc document, opens a non-modal dialog with a text box, ''' let the user make a selection in the current or another sheet and ''' returns the selected area as a string. ''' This method does not change the current selection. ''' Args: ''' Title: the title to display on the top of the dialog ''' Selection: a default preselection as a String. When absent, the first element of the ''' current selection is preselected. ''' SingleCell: When True, only a single cell may be selected. Default = False ''' CloseAfterSelect: When True (default-, the dialog is closed immediately after ''' the selection. When False, the user may change his/her mind and must close ''' the dialog manually. ''' Returns: ''' The selected range as a string, or the empty string when the user cancelled the request (close window button) ''' Exceptions: ''' Examples: ''' Dim sSelect As String, vValues As Variant ''' sSelect = oDoc.OpenRangeSelector("Select a range ...") ''' If sSelect = "" Then Exit Function ''' vValues = oDoc.GetValue(sSelect) Dim sSelector As String ' Return value Dim vPropertyValues As Variant ' Array of com.sun.star.beans.PropertyValue Dim oSelection As Object ' The current selection before opening the selector Dim oAddress As Object ' Preselected address as _Address Const cstThisSub = "SFDocuments.Calc.OpenRangeSelector" Const cstSubArgs = "[Title=""""], [Selection=""~""], [SingleCell=False], [CloseAfterSelect=True]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sSelector = "" Check: If IsMissing(Title) Or IsEmpty(Title) Then Title = "" If IsMissing(Selection) Or IsEmpty(Selection) Then Selection = "~" If IsMissing(SingleCell) Or IsEmpty(SingleCell) Then SingleCell = False If IsMissing(CloseAfterSelect) Or IsEmpty(CloseAfterSelect) Then CloseAfterSelect = True If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Title, "Title", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Selection, "Selection", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(SingleCell, "SingleCell", ScriptForge.V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(CloseAfterSelect, "CloseAfterSelect", ScriptForge.V_BOOLEAN) Then GoTo Finally End If Try: ' Save the current selections Set oSelection = _Component.CurrentController.getSelection() ' Process preselection and select its containing sheet Set oAddress = _ParseAddress(Selection) Activate(oAddress.SheetName) ' Build arguments array and execute the dialog box With ScriptForge.SF_Utils vPropertyValues = Array( _ ._MakePropertyValue("Title", Title) _ , ._MakePropertyValue("CloseOnMouseRelease", CloseAfterSelect) _ , ._MakePropertyValue("InitialValue", oAddress.XCellRange.AbsoluteName) _ , ._MakePropertyValue("SingleCellMode", SingleCell) _ ) End With sSelector = SF_DocumentListener.RunRangeSelector(_Component, vPropertyValues) ' Restore the saved selections _RestoreSelections(_Component, oSelection) Finally: OpenRangeSelector = sSelector ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.OpenRangeSelector REM ----------------------------------------------------------------------------- Public Function Printf(Optional ByVal InputStr As Variant _ , Optional ByVal Range As Variant _ , Optional ByVal TokenCharacter As Variant _ ) As String ''' Returns the input string after substitution of its tokens by ''' their values in the given range ''' This method is usually used in combination with SetFormula() ''' The accepted tokens are: ''' - %S The sheet name containing the range, including single quotes when necessary ''' - %R1 The row number of the topleft part of the range ''' - %C1 The column letter of the topleft part of the range ''' - %R2 The row number of the bottomright part of the range ''' - %C2 The column letter of the bottomright part of the range ''' Args: ''' InputStr: usually a Calc formula or a part of a formula, but may be any string ''' Range: the range, as a string from which the values of the tokens are derived ''' TokenCharacter: the character identifying tokens. Default = "%". ''' Double the TokenCharacter to not consider it as a token. ''' Returns: ''' The input string after substitution of the contained tokens ''' Exceptions: ''' Examples: ''' Assume we have in A1:E10 a matrix of numbers. To obtain the sum by row in F1:F10 ... ''' Dim range As String, formula As String ''' range = "$A$1:$E$10") ''' formula = "=SUM($%C1%R1:$%C2%R1)" ' "=SUM($A1:$E1)", note the relative references ''' oDoc.SetFormula("$F$1:$F$10", formula) ''' 'F1 will contain =Sum($A1:$E1) ''' 'F2 =Sum($A2:$E2) ''' ' ... Dim sPrintf As String ' Return value Dim vSubstitute As Variants ' Array of strings representing the token values Dim oAddress As Object ' A range as an _Address object Dim sSheetName As String ' The %S token value Dim sC1 As String ' The %C1 token value Dim sR1 As String ' The %R1 token value Dim sC2 As String ' The %C2 token value Dim sR2 As String ' The %R2 token value Dim i As Long Const cstPseudoToken = "@#@" Const cstThisSub = "SFDocuments.Calc.Printf" Const cstSubArgs = "InputStr, Range, TokenCharacter=""%""" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sPrintf = "" Check: If IsMissing(TokenCharacter) Or IsEmpty(TokenCharacter) Then TokenCharacter = "%" If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(TokenCharacter, "TokenCharacter", V_STRING) Then GoTo Finally End If Try: ' Define the token values Set oAddress = _ParseAddress(Range) With oAddress.XCellRange sC1 = _GetColumnName(.RangeAddress.StartColumn + 1) sR1 = CStr(.RangeAddress.StartRow + 1) sC2 = _GetColumnName(.RangeAddress.EndColumn + 1) sR2 = CStr(.RangeAddress.EndRow + 1) sSheetName = _QuoteSheetName(oAddress.XSpreadsheet.Name) End With ' Substitute tokens by their values sPrintf = ScriptForge.SF_String.ReplaceStr(InputStr _ , Array(TokenCharacter & TokenCharacter _ , TokenCharacter & "R1" _ , TokenCharacter & "C1" _ , TokenCharacter & "R2" _ , TokenCharacter & "C2" _ , TokenCharacter & "S" _ , cstPseudoToken _ ) _ , Array(cstPseudoToken _ , sR1 _ , sC1 _ , sR2 _ , sC2 _ , sSheetName _ , TokenCharacter _ ) _ ) Finally: Printf = sPrintf ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.Printf REM ----------------------------------------------------------------------------- Public Function PrintOut(Optional ByVal SheetName As Variant _ , Optional ByVal Pages As Variant _ , Optional ByVal Copies As Variant _ ) As Boolean ''' Send the content of the given sheet to the printer. ''' The printer might be defined previously by default, by the user or by the SetPrinter() method ''' Args: ''' SheetName: the sheet to print. Default = the active sheet ''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages ''' Copies: the number of copies ''' Returns: ''' True when successful ''' Examples: ''' oDoc.PrintOut("SheetX", "1-4;10;15-18", Copies := 2) Dim bPrint As Boolean ' Return value Dim oSheet As Object ' SheetName as a reference Const cstThisSub = "SFDocuments.Calc.PrintOut" Const cstSubArgs = "[SheetName=""~""], [Pages=""""], [Copies=1]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bPrint = False Check: If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = "" If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = "" If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not _ValidateSheet(SheetName, "SheetName", , True, True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Pages, "Pages", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally End If Try: If SheetName = "~" Then SheetName = "" ' Make given sheet active If Len(SheetName) > 0 Then With _Component Set oSheet = .getSheets.getByName(SheetName) Set .CurrentController.ActiveSheet = oSheet End With End If bPrint = [_Super].PrintOut(Pages, Copies, _Component) Finally: PrintOut = bPrint ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.PrintOut REM ----------------------------------------------------------------------------- Public Function Properties() As Variant ''' Return the list or properties of the Calc class as an array Properties = Array( _ "CurrentSelection" _ , "CustomProperties" _ , "Description" _ , "DocumentProperties" _ , "DocumentType" _ , "ExportFilters" _ , "FirstCell" _ , "FirstColumn" _ , "FirstRow" _ , "Height" _ , "ImportFilters" _ , "IsBase" _ , "IsCalc" _ , "IsDraw" _ , "IsFormDocument" _ , "IsImpress" _ , "IsMath" _ , "IsWriter" _ , "Keywords" _ , "LastCell" _ , "LastColumn" _ , "LastRow" _ , "Range" _ , "Readonly" _ , "Region" _ , "Sheet" _ , "SheetName" _ , "Sheets" _ , "Subject" _ , "Title" _ , "Width" _ , "XCellRange" _ , "XComponent" _ , "XSheetCellCursor" _ , "XSpreadsheet" _ ) End Function ' SFDocuments.SF_Calc.Properties REM ----------------------------------------------------------------------------- Public Function RemoveDuplicates(Optional ByVal Range As Variant _ , Optional ByVal Columns As Variant _ , Optional ByVal Header As Variant _ , Optional ByVal CaseSensitive As Variant _ , Optional ByVal Mode As Variant _ ) As String ''' Remove duplicate values from a range of values. ''' The comparison between rows is done on a subset of the columns in the range. ''' The resulting range replaces the input range, in which, either: ''' all duplicate rows are cleared from their content ''' all duplicate rows are suppressed and rows below are pushed upwards. ''' Anyway, the first copy of each set of duplicates is kept and the initial sequence is preserved. ''' Args: ''' Range: the range, as a string, from which the duplicate rows should be removed ''' Columns: an array of column numbers to compare; items are in the interval [1 .. range width] ''' Default = the first column in the range ''' Header: when True, the first row is a header row. Default = False. ''' CaseSensitive: for string comparisons. Default = False. ''' Mode: either "CLEAR" or "COMPACT" (Default) ''' For large ranges, the "COMPACT" mode is probably significantly slower. ''' Returns: ''' The resulting range as a string ''' Examples: ''' oCalc.RemoveDuplicates("Sheet1.B2:K11", Array(1, 2), Header := True, CaseSensitive := True) Dim sRemove As String ' Return value Dim oRangeAddress As Object ' Parsed range as an _Address object Dim sMirrorRange As String ' Mirror of initial range Dim lRandom As Long ' Random number to build the worksheet name Dim sWorkSheet As String ' Name of worksheet Dim vRows() As Variant ' Array of row numbers Dim sRowsRange As String ' Range of the last column of the worksheet Dim sFullMirrorRange As String ' Mirrored data + rows column Dim sLastRowsRange As String ' Same as sRowsRange without the first cell Dim sDuplicates As String ' Formula identifying a duplicate row Dim lColumn As Long ' Single column number Dim sColumn As String ' Single column name Dim sFilter As String ' Filter formula for final compaction or clearing Const cstThisSub = "SFDocuments.Calc.RemoveDuplicates" Const cstSubArgs = "Range, [Columns], [Header=False], [CaseSensitive=False], [Mode=""COMPACT""|""CLEAR""]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sRemove = "" Check: If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = Array(1) If Not IsArray(Columns) Then Columns = Array(Columns) If IsMissing(Header) Or IsEmpty(Header) Then Header = False If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False If IsMissing(Mode) Or IsEmpty(Mode) Then Mode = "COMPACT" 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._ValidateArray(Columns, "Columns", 1, ScriptForge.V_NUMERIC, True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Header, "Header", ScriptForge.V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", ScriptForge.V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Mode, "Mode", V_STRING, Array("COMPACT", "CLEAR")) Then GoTo Finally End If Try: ' Let's assume the initial range is "$Sheet1.$B$11:$K$110" (100 rows, 10 columns, no header) ' Ignore header, consider only the effective data If Header Then Set oRangeAddress = _Offset(Range, 1, 0, Height(Range) - 1, 0) Else Set oRangeAddress = _ParseAddress(Range) '** Step 1: create a worksheet and copy the range in A1 lRandom = ScriptForge.SF_Session.ExecuteCalcFunction("RANDBETWEEN.NV", 1, 999999) sWorkSheet = "SF_WORK_" & Right("000000" & lRandom, 6) InsertSheet(sWorkSheet) ' sMirrorRange = "$SF_WORK.$A$1:$J$100" sMirrorRange = CopyToCell(oRangeAddress, "$" & sWorkSheet & ".$A$1") '** Step 2: add a column in the mirror with the row numbers in the initial range ' vRows = [11..110] With oRangeAddress.XCellRange vRows = ScriptForge.RangeInit(CLng(.RangeAddress.StartRow + 1), CLng(.RangeAddress.EndRow + 1)) End With ' sRowsRange = "$SF_WORK.$K$1:$K$100" sRowsRange = SetArray(Offset(sMirrorRange, , Width(sMirrorRange), 1, 1), vRows()) '** Step 3: sort the mirrored data, including the row numbers column ' sFullMirrorRange = "$SF_WORK.$A$1:$K$100" sFullMirrorRange = Offset(sMirrorRange, , , , Width(sMirrorRange) + 1) SortRange(sFullMirrorRange, SortKeys := Columns, CaseSensitive := CaseSensitive) '** Step 4: Filter out the row numbers containing duplicates ' sLastRowRange = "$SF_WORK.$K$2:$K$100" sLastRowsRange = Offset(sRowsRange, 1, , Height(sRowsRange) - 1) ' If Columns = (1, 3) => sDuplicates = "=AND(TRUE;$A2=$A1;$C2=$C1) sDuplicates = "=AND(TRUE" For Each lColumn In Columns sColumn = _GetColumnName(lColumn) If CaseSensitive Then sDuplicates = sDuplicates & ";$" & sColumn & "2=$" & sColumn & "1" Else sDuplicates = sDuplicates & ";UPPER($" & sColumn & "2)=UPPER($" & sColumn & "1)" End If Next lColumn sDuplicates = sDuplicates & ")" ClearValues(sLastRowsRange, sDuplicates, "ROW") '** Step 5: Compact or clear the rows in the initial range that are not retained in the final row numbers list ' sFilter = "=ISNA(MATCH(ROW();$SF_WORK.$K$1:$K$100;0))" sFilter = "=ISNA(MATCH(ROW();" & sRowsRange & ";0))" Select Case UCase(Mode) Case "COMPACT" sRemove = CompactUp(oRangeAddress.RangeName, WholeRow := False, FilterFormula := sFilter) If Header Then sRemove = Offset(sRemove, -1, 0, Height(sRemove) + 1) Case "CLEAR" ClearValues(oRangeAddress.RangeName, FilterFormula := sFilter, FilterScope := "ROW") If Header Then sRemove = _ParseAddress(Range).RangeName Else sRemove = oRangeAddress.RangeName End Select '** Housekeeping RemoveSheet(sWorkSheet) Finally: RemoveDuplicates = sRemove ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.RemoveDuplicates REM ----------------------------------------------------------------------------- Public Function RemoveSheet(Optional ByVal SheetName As Variant) As Boolean ''' Remove an existing sheet from the document ''' Args: ''' SheetName: The name of the sheet to remove ''' Returns: ''' True if the sheet could be removed successfully ''' Examples: ''' oDoc.RemoveSheet("SheetX") Dim bRemove As Boolean ' Return value Const cstThisSub = "SFDocuments.Calc.RemoveSheet" Const cstSubArgs = "SheetName" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bRemove = False Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive(True) Then GoTo Finally If Not _ValidateSheet(SheetName, "SheetName", , True) Then GoTo Finally End If Try: _Component.getSheets.RemoveByName(SheetName) bRemove = True Finally: RemoveSheet = bRemove ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.RemoveSheet REM ----------------------------------------------------------------------------- Public Function RenameSheet(Optional ByVal SheetName As Variant _ , Optional ByVal NewName As Variant _ ) As Boolean ''' Rename a specified sheet ''' Args: ''' SheetName: The name of the sheet to rename ''' NewName: Must not exist ''' Returns: ''' True if the sheet could be renamed successfully ''' Exceptions: ''' DUPLICATESHEETERROR A sheet with the given name exists already ''' Examples: ''' oDoc.RenameSheet("SheetX", "SheetY") Dim bRename As Boolean ' Return value Const cstThisSub = "SFDocuments.Calc.RenameSheet" Const cstSubArgs = "SheetName, NewName" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bRename = False Check: 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 _ValidateSheet(NewName, "NewName", True) Then GoTo Finally End If Try: _Component.getSheets.getByName(SheetName).setName(NewName) bRename = True Finally: RenameSheet = bRename ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.RenameSheet REM ----------------------------------------------------------------------------- Public Function SetArray(Optional ByVal TargetCell As Variant _ , Optional ByRef Value As Variant _ ) As String ''' Set the given (array of) values starting from the target cell ''' The updated area expands itself from the target cell or from the top-left corner of the given range ''' as far as determined by the size of the input Value. ''' Vectors are always expanded vertically ''' Args: ''' TargetCell : the cell or the range as a string that should receive a new value ''' Value: a scalar, a vector or an array with the new values ''' The new values should be strings, numeric values or dates. Other types empty the corresponding cell ''' Returns: ''' A string representing the updated range ''' Exceptions: ''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries ''' Examples: ''' oDoc.SetArray("SheetX.A1", SF_Array.RangeInit(1, 1000)) Dim sSet As String ' Return value Dim oSet As Object ' _Address alias of sSet Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property Const cstThisSub = "SFDocuments.Calc.SetArray" Const cstSubArgs = "TargetCell, Value" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sSet = "" Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(TargetCell, "TargetCell", V_STRING) Then GoTo Finally If IsArray(Value) Then If Not ScriptForge.SF_Utils._ValidateArray(Value, "Value") Then GoTo Finally Else If Not ScriptForge.SF_Utils._Validate(Value, "Value") Then GoTo Finally End If End If Try: ' Convert argument to data array and derive new range from its size vDataArray = _ConvertToDataArray(Value) If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally Set oSet = _Offset(TargetCell, 0, 0, plHeight := UBound(vDataArray) + 1, plWidth := UBound(vDataArray(0)) + 1) ' +1 : vDataArray is zero-based With oSet .XCellRange.setDataArray(vDataArray) sSet = .RangeName End With Finally: SetArray = sSet ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.SetArray REM ----------------------------------------------------------------------------- Public Function SetCellStyle(Optional ByVal TargetRange As Variant _ , Optional ByVal Style As Variant _ , Optional ByVal FilterFormula As Variant _ , Optional ByVal FilterScope As Variant _ ) As String ''' Apply the given cell style in the given range ''' If the cell style does not exist, an error is raised ''' The range is updated and the remainder of the sheet is left untouched ''' Either the full range is updated or a selection based on a FilterFormula ''' Args: ''' TargetRange : the range as a string that should receive a new cell style ''' Style: the style name as a string ''' FilterFormula: a Calc formula to select among the given Range ''' When left empty, all the cells of the range are formatted with the new style ''' FilterScope: "CELL" (default value), "ROW" or "COLUMN" ''' When FilterFormula is present, FilterScope is mandatory ''' Returns: ''' A string representing the updated range ''' Examples: ''' oDoc.SetCellStyle("A1:F1", "Heading 2") ''' oDoc.SetCellStype("A1:J20", "Wrong", "=(A1<0)", "CELL") Dim sSet As String ' Return value Dim oAddress As _Address ' Alias of TargetRange Dim oStyleFamilies As Object ' com.sun.star.container.XNameAccess Dim vStyles As Variant ' Array of existing cell styles Dim vRanges() As Variant ' Array of filtered ranges Dim i As Long Const cstStyle = "CellStyles" Const cstThisSub = "SFDocuments.Calc.SetCellStyle" Const cstSubArgs = "TargetRange, Style, [FilterFormula=""], [FilterScope=""CELL""|""ROW""|""COLUMN""]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sSet = "" Check: If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = "" If IsMissing(FilterScope) Or IsEmpty(FilterScope) Then FilterScope = "CELL" If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally ' Check that the given style really exists Set oStyleFamilies = _Component.StyleFamilies If oStyleFamilies.hasByName(cstStyle) Then vStyles = oStyleFamilies.getByName(cstStyle).getElementNames() Else vStyles = Array() If Not ScriptForge.SF_Utils._Validate(Style, "Style", V_STRING, vStyles) Then GoTo Finally ' Filter formula 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 oAddress = _ParseAddress(TargetRange) Else Set oAddress = TargetRange With oAddress If Len(FilterFormula) = 0 Then ' When the full range should be updated .XCellRange.CellStyle = Style Else ' When the range has to be cut in subranges vRanges() = _ComputeFilter(oAddress, FilterFormula, UCase(FilterScope)) For i = 0 To UBound(vRanges) vRanges(i).XCellRange.CellStyle = Style Next i End If sSet = .RangeName End With Finally: SetCellStyle = sSet ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.SetCellStyle REM ----------------------------------------------------------------------------- Public Function SetFormula(Optional ByVal TargetRange As Variant _ , Optional ByRef Formula As Variant _ ) As String ''' Set the given (array of) formulae in the given range ''' The full range is updated and the remainder of the sheet is left untouched ''' If the given formula is a string: ''' the unique formula is pasted across the whole range with adjustment of the relative references ''' Otherwise ''' If the size of Formula < the size of Range, then the other cells are emptied ''' If the size of Formula > the size of Range, then Formula is only partially copied ''' Vectors are always expanded vertically, except if the range has a height of exactly 1 row ''' Args: ''' TargetRange : the range as a string that should receive a new Formula ''' Formula: a scalar, a vector or an array with the new formula(e) as strings for each cell of the range. ''' Returns: ''' A string representing the updated range ''' Examples: ''' oDoc.SetFormula("A1", "=A2") ''' oDoc.SetFormula("A1:F1", Array("=A2", "=B2", "=C2+10")) ' Horizontal vector, partially empty ''' oDoc.SetFormula("A1:D2", "=E1") ' D2 contains the formula "=H2" Dim sSet As String ' Return value.XSpreadsheet.Name) Dim oAddress As Object ' Alias of TargetRange Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property Const cstThisSub = "SFDocuments.Calc.SetFormula" Const cstSubArgs = "TargetRange, Formula" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sSet = "" Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally If IsArray(Formula) Then If Not ScriptForge.SF_Utils._ValidateArray(Formula, "Formula", 0, V_STRING) Then GoTo Finally Else If Not ScriptForge.SF_Utils._Validate(Formula, "Formula", V_STRING) Then GoTo Finally End If End If Try: If VarType(TargetRange) = V_STRING Then Set oAddress = _ParseAddress(TargetRange) Else Set oAddress = TargetRange With oAddress If IsArray(Formula) Then ' Convert to data array and limit its size to the size of the initial range vDataArray = _ConvertToDataArray(Formula, .Height - 1, .Width - 1) If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally .XCellRange.setFormulaArray(vDataArray) Else With .XCellRange ' Store formula in top-left cell and paste it along the whole range .getCellByPosition(0, 0).setFormula(Formula) .fillSeries(com.sun.star.sheet.FillDirection.TO_BOTTOM, com.sun.star.sheet.FillMode.SIMPLE, 0, 0, 0) .fillSeries(com.sun.star.sheet.FillDirection.TO_RIGHT, com.sun.star.sheet.FillMode.SIMPLE, 0, 0, 0) End With End If sSet = .RangeName End With Finally: SetFormula = sSet ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.SetFormula REM ----------------------------------------------------------------------------- Private Function SetProperty(Optional ByVal psProperty As String _ , Optional ByVal pvValue As Variant _ ) As Boolean ''' Set the new value of the named property ''' Args: ''' psProperty: the name of the property ''' pvValue: the new value of the given property ''' Returns: ''' True if successful Dim bSet As Boolean ' Return value Static oSession As Object ' Alias of SF_Session Dim cstThisSub As String Const cstSubArgs = "Value" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bSet = False cstThisSub = "SFDocuments.Calc.set" & psProperty If IsMissing(pvValue) Then pvValue = Empty 'ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Validation done in Property Lets If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") bSet = True Select Case UCase(psProperty) Case UCase("CurrentSelection") CurrentSelection = pvValue Case UCase("CustomProperties") CustomProperties = pvValue Case UCase("Description") Description = pvValue Case UCase("Keywords") Keywords = pvValue Case UCase("Subject") Subject = pvValue Case UCase("Title") Title = pvValue Case Else bSet = False End Select Finally: SetProperty = bSet 'ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.SetProperty REM ----------------------------------------------------------------------------- Public Function SetValue(Optional ByVal TargetRange As Variant _ , Optional ByRef Value As Variant _ ) As String ''' Set the given value in the given range ''' The full range is updated and the remainder of the sheet is left untouched ''' If the size of Value < the size of Range, then the other cells are emptied ''' If the size of Value > the size of Range, then Value is only partially copied ''' Vectors are always expanded vertically, except if the range has a height of exactly 1 row ''' Args: ''' TargetRange : the range as a string that should receive a new value ''' Value: a scalar, a vector or an array with the new values for each cell o.XSpreadsheet.Name)f the range. ''' The new values should be strings, numeric values or dates. Other types empty the corresponding cell ''' Returns: ''' A string representing the updated range ''' Examples: ''' oDoc.SetValue("A1", 2) ''' oDoc.SetValue("A1:F1", Array(1, 2, 3)) ' Horizontal vector, partially empty ''' oDoc.SetValue("A1:D2", SF_Array.AppendRow(Array(1, 2, 3, 4), Array(5, 6, 7, 8))) Dim sSet As String ' Return value Dim oAddress As Object ' Alias of TargetRange Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property Const cstThisSub = "SFDocuments.Calc.SetValue" Const cstSubArgs = "TargetRange, Value" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sSet = "" Check: 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 IsArray(Value) Then If Not ScriptForge.SF_Utils._ValidateArray(Value, "Value") Then GoTo Finally Else If Not ScriptForge.SF_Utils._Validate(Value, "Value") Then GoTo Finally End If End If Try: Set oAddress = _ParseAddress(TargetRange) With oAddress ' Convert to data array and limit its size to the size of the initial range vDataArray = _ConvertToDataArray(Value, .Height - 1, .Width - 1) If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally .XCellRange.setDataArray(vDataArray) sSet = .RangeName End With Finally: SetValue = sSet ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.SetValue REM ----------------------------------------------------------------------------- Public Function ShiftDown(Optional ByVal Range As Variant _ , Optional ByVal WholeRow As Variant _ , Optional ByVal Rows As Variant _ ) As String ''' Move a specified range and all cells below in the same columns downwards by inserting empty cells ''' The inserted cells can span whole rows or be limited to the width of the range ''' The height of the inserted area is provided by the Rows argument ''' Nothing happens if the range shift crosses one of the edges of the worksheet ''' The execution of the method has no effect on the current selection ''' Args: ''' Range: the range above which cells have to be inserted, as a string ''' WholeRow: when True (default = False), insert whole rows ''' Rows: the height of the area to insert. Default = the height of the Range argument ''' Returns: ''' A string representing the new location of the initial range ''' Examples: ''' newrange = oDoc.ShiftDown("SheetX.A1:F10") ' "$SheetX.$A$11:$F$20" ''' newrange = oDoc.ShiftDown("SheetX.A1:F10", Rows := 3) ' "$SheetX.$A$4:$F$13" Dim sShift As String ' Return value Dim oSourceAddress As Object ' Alias of Range as _Address Dim lHeight As Long ' Range height Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellInsertMode enum values Const cstThisSub = "SFDocuments.Calc.ShiftDown" Const cstSubArgs = "Range, [WholeRow=False], [Rows]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sShift = "" Check: If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0 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(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally End If Try: Set oSourceAddress = _ParseAddress(Range) With oSourceAddress ' Manage the height of the area to shift ' The insertCells() method inserts a number of rows equal to the height of the cell range to shift lHeight = .Height If Rows <= 0 Then Rows = lHeight If _LastCell(.XSpreadsheet)(1) + Rows > MAXROWS Then GoTo Catch If Rows <> lHeight Then Set oShiftAddress = _Offset(oSourceAddress, 0, 0, Rows, 0).XCellRange.RangeAddress Else Set oShiftAddress = .XCellRange.RangeAddress End If ' Determine the shift mode With com.sun.star.sheet.CellInsertMode If WholeRow Then lShiftMode = .ROWS Else lShiftMode = .DOWN End With ' Move the cells as requested. This modifies .XCellRange .XSpreadsheet.insertCells(oShiftAddress, lShiftMode) ' Determine the receiving area sShift = .XCellRange.AbsoluteName End With Finally: ShiftDown = sShift ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: ' When error, return the original range If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName GoTo Finally End Function ' SFDocuments.SF_Calc.ShiftDown REM ----------------------------------------------------------------------------- Public Function ShiftLeft(Optional ByVal Range As Variant _ , Optional ByVal WholeColumn As Variant _ , Optional ByVal Columns As Variant _ ) As String ''' Delete the leftmost columns of a specified range and move all cells at their right leftwards ''' The deleted cells can span whole columns or be limited to the height of the range ''' The width of the deleted area is provided by the Columns argument ''' 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 ''' Columns: the width of the area to delete. ''' Default = the width of the Range argument, it is also its maximum value ''' Returns: ''' A string representing the location of the remaining part of the initial range, ''' or the zero-length string if the whole range has been deleted ''' Examples: ''' newrange = oDoc.ShiftLeft("SheetX.G1:L10") ' """ ''' newrange = oDoc.ShiftLeft("SheetX.G1:L10", Columns := 3) ' "$SheetX.$G$1:$I$10" Dim sShift As String ' Return value Dim oSourceAddress As Object ' Alias of Range as _Address Dim lWidth As Long ' Range width Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellDeleteMode enum values Const cstThisSub = "SFDocuments.Calc.ShiftLeft" Const cstSubArgs = "Range, [WholeColumn=False], [Columns]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sShift = "" Check: If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0 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(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally End If Try: Set oSourceAddress = _ParseAddress(Range) Set _LastParsedAddress = Nothing ' Range will be erased. Force re-parsing next time With oSourceAddress ' Manage the width of the area to delete ' The removeRange() method erases a number of columns equal to the width of the cell range to delete lWidth = .Width If Columns <= 0 Then Columns = lWidth If Columns < lWidth Then Set oShiftAddress = _Offset(oSourceAddress, 0, 0, 0, Columns).XCellRange.RangeAddress Else ' Columns is capped at the range width Set oShiftAddress = .XCellRange.RangeAddress End If ' Determine the Delete mode With com.sun.star.sheet.CellDeleteMode If WholeColumn Then lShiftMode = .COLUMNS Else lShiftMode = .LEFT End With ' Move the cells as requested. This modifies .XCellRange .XSpreadsheet.removeRange(oShiftAddress, lShiftMode) ' Determine the remaining area If Columns < lWidth Then sShift = .XCellRange.AbsoluteName End With Finally: ShiftLeft = sShift ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: ' When error, return the original range If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName GoTo Finally End Function ' SFDocuments.SF_Calc.ShiftLeft REM ----------------------------------------------------------------------------- Public Function ShiftRight(Optional ByVal Range As Variant _ , Optional ByVal WholeColumn As Variant _ , Optional ByVal Columns As Variant _ ) As String ''' Move a specified range and all next cells in the same rows to the right by inserting empty cells ''' The inserted cells can span whole columns or be limited to the height of the range ''' The width of the inserted area is provided by the Columns argument ''' Nothing happens if the range shift crosses one of the edges of the worksheet ''' The execution of the method has no effect on the current selection ''' Args: ''' Range: the range before which cells have to be inserted, as a string ''' WholeColumn: when True (default = False), insert whole columns ''' Columns: the width of the area to insert. Default = the width of the Range argument ''' Returns: ''' A string representing the new location of the initial range ''' Examples: ''' newrange = oDoc.ShiftRight("SheetX.A1:F10") ' "$SheetX.$G$1:$L$10" ''' newrange = oDoc.ShiftRight("SheetX.A1:F10", Columns := 3) ' "$SheetX.$D$1:$I$10" Dim sShift As String ' Return value Dim oSourceAddress As Object ' Alias of Range as _Address Dim lWidth As Long ' Range width Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellInsertMode enum values Const cstThisSub = "SFDocuments.Calc.ShiftRight" Const cstSubArgs = "Range, [WholeColumn=False], [Columns]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sShift = "" Check: If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0 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(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally End If Try: Set oSourceAddress = _ParseAddress(Range) With oSourceAddress ' Manage the width of the area to Shift ' The insertCells() method inserts a number of columns equal to the width of the cell range to Shift lWidth = .Width If Columns <= 0 Then Columns = lWidth If _LastCell(.XSpreadsheet)(0) + Columns > MAXCOLS Then GoTo Catch If Columns <> lWidth Then Set oShiftAddress = _Offset(oSourceAddress, 0, 0, 0, Columns).XCellRange.RangeAddress Else Set oShiftAddress = .XCellRange.RangeAddress End If ' Determine the Shift mode With com.sun.star.sheet.CellInsertMode If WholeColumn Then lShiftMode = .COLUMNS Else lShiftMode = .RIGHT End With ' Move the cells as requested. This modifies .XCellRange .XSpreadsheet.insertCells(oShiftAddress, lShiftMode) ' Determine the receiving area sShift = .XCellRange.AbsoluteName End With Finally: ShiftRight = sShift ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: ' When error, return the original range If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName GoTo Finally End Function ' SFDocuments.SF_Calc.ShiftRight REM ----------------------------------------------------------------------------- Public Function ShiftUp(Optional ByVal Range As Variant _ , Optional ByVal WholeRow As Variant _ , Optional ByVal Rows As Variant _ ) As String ''' Delete the topmost rows of a specified range and move all cells below upwards ''' The deleted cells can span whole rows or be limited to the width of the range ''' The height of the deleted area is provided by the Rows argument ''' 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 ''' Rows: the height of the area to delete. ''' Default = the height of the Range argument, it is also its maximum value ''' Returns: ''' A string representing the location of the remaining part of the initial range, ''' or the zero-length string if the whole range has been deleted ''' Examples: ''' newrange = oDoc.ShiftUp("SheetX.G1:L10") ' "" ''' newrange = oDoc.ShiftUp("SheetX.G1:L10", Rows := 3) ' "$SheetX.$G$1:$I$10" Dim sShift As String ' Return value Dim oSourceAddress As Object ' Alias of Range as _Address Dim lHeight As Long ' Range height Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right height Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellDeleteMode enum values Const cstThisSub = "SFDocuments.Calc.ShiftUp" Const cstSubArgs = "Range, [WholeRow=False], [Rows]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sShift = "" Check: If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0 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(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally End If Try: Set oSourceAddress = _ParseAddress(Range) Set _LastParsedAddress = Nothing ' Range will be erased. Force re-parsing next time With oSourceAddress ' Manage the height of the area to delete ' The removeRange() method erases a number of rows equal to the height of the cell range to delete lHeight = .Height If Rows <= 0 Then Rows = lHeight If Rows < lHeight Then Set oShiftAddress = _Offset(oSourceAddress, 0, 0, Rows, 0).XCellRange.RangeAddress Else ' Rows is capped at the range height Set oShiftAddress = .XCellRange.RangeAddress End If ' Determine the Delete mode With com.sun.star.sheet.CellDeleteMode If WholeRow Then lShiftMode = .ROWS Else lShiftMode = .UP End With ' Move the cells as requested. This modifies .XCellRange .XSpreadsheet.removeRange(oShiftAddress, lShiftMode) ' Determine the remaining area If Rows < lHeight Then sShift = .XCellRange.AbsoluteName End With Finally: ShiftUp = sShift ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: ' When error, return the original range If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName GoTo Finally End Function ' SFDocuments.SF_Calc.ShiftUp REM ----------------------------------------------------------------------------- Public Function SortRange(Optional ByVal Range As Variant _ , Optional ByVal SortKeys As Variant _ , Optional ByVal SortOrder As Variant _ , Optional ByVal DestinationCell As Variant _ , Optional ByVal ContainsHeader As Variant _ , Optional ByVal CaseSensitive As Variant _ , Optional ByVal SortColumns As Variant _ ) As Variant ''' Sort the given range on any number of columns/rows. The sorting order may vary by column/row ''' If the number of sort keys is > 3 then the range is sorted several times, by groups of 3 keys, ''' starting from the last key. In this context the algorithm used by Calc to sort ranges ''' is presumed STABLE, i.e. it maintains the relative order of records with equal keys. ''' ''' Args: ''' Range: the range to sort as a string ''' SortKeys: a scalar (if 1 column/row) or an array of column/row numbers starting from 1 ''' SortOrder: a scalar or an array of strings: "ASC" or "DESC" ''' Each item is paired with the corresponding item in SortKeys ''' If the SortOrder array is shorter than SortKeys, the remaining keys are sorted ''' in ascending order ''' DestinationCell: the destination of the sorted range of cells, as a string ''' If given as range, the destination will be reduced to its top-left cell ''' By default, Range is overwritten with its sorted content ''' ContainsHeader: when True, the first row/column is not sorted. Default = False ''' CaseSensitive: only for string comparisons, default = False ''' SortColumns: when True, the columns are sorted from left to right ''' Default = False: rows are sorted from top to bottom. ''' Returns: ''' The modified range of cells as a string ''' Example: ''' oDoc.SortRange("A2:J200", Array(1, 3), , Array("ASC", "DESC"), CaseSensitive := True) ''' ' Sort on columns A (ascending) and C (descending) Dim sSort As String ' Return value Dim oRangeAddress As _Address ' Parsed range Dim oRange As Object ' com.sun.star.table.XCellRange Dim oSortRange As Object ' The area to sort as an _Address object 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 vSortDescriptor As Variant ' Array of com.sun.star.beans.PropertyValue Dim vSortFields As Variant ' Array of com.sun.star.table.TableSortField Dim sOrder As String ' Item in SortOrder Dim lSort As Long ' Counter for sub-sorts Dim lKeys As Long ' UBound of SortKeys Dim lKey As Long ' Actual index in SortKeys Dim i As Long, j As Long Const cstMaxKeys = 3 ' Maximum number of keys allowed in a single sorting step Const cstThisSub = "SFDocuments.Calc.SortRange" Const cstSubArgs = "Range, SortKeys, [TargetRange=""""], [SortOrder=""ASC""], [DestinationCell=""""], [ContainsHeader=False], [CaseSensitive=False], [SortColumns=False]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch sSort = "" Check: If IsMissing(SortKeys) Or IsEmpty(SortKeys) Then SortKeys = Array(1) ElseIf Not IsArray(SortKeys) Then SortKeys = Array(SortKeys) End If If IsMissing(DestinationCell) Or IsEmpty(DestinationCell) Then DestinationCell = "" If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then SortOrder = Array("ASC") ElseIf Not IsArray(SortOrder) Then SortOrder = Array(SortOrder) End If If IsMissing(ContainsHeader) Or IsEmpty(ContainsHeader) Then ContainsHeader = False If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False If IsMissing(SortColumns) Or IsEmpty(SortColumns) Then SortColumns = False If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._ValidateArray(SortKeys, "SortKeys", 1, V_NUMERIC, True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally If Not ScriptForge.SF_Utils._ValidateArray(SortOrder, "SortOrder", 1, V_STRING, True) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(ContainsHeader, "ContainsHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", ScriptForge.V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(SortColumns, "SortColumns", ScriptForge.V_BOOLEAN) Then GoTo Finally End If Set oRangeAddress = _ParseAddress(Range) If Len(DestinationCell) > 0 Then Set oDestRange = _ParseAddress(DestinationCell) Else Set oDestRange = Nothing Try: ' Initialize a generic sort descriptor Set oRange = oRangeAddress.XCellRange vSortDescriptor = oRange.createSortDescriptor ' Makes a generic sort descriptor for ranges vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsSortColumns", SortColumns) vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "ContainsHeader", ContainsHeader) vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "BindFormatsToContent", True) vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsUserListEnabled", False) ' Sort by keys group ' If keys = (1, 2, 3, 4, 5) then groups = (4, 5), (1, 2, 3) lKeys = UBound(SortKeys) lSort = Int(lKeys / cstMaxKeys) Set oSortRange = oRangeAddress For j = lSort To 0 Step -1 ' Sort first on last sort keys ' The 1st sort must consider the destination area. Next sorts are done on the destination area If Len(DestinationCell) = 0 Or j < lSort Then vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", False) vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "OutputPosition", Nothing) Else Set oDestAddress = oDestRange.XCellRange.RangeAddress Set oDestCell = New com.sun.star.table.CellAddress With oDestAddress oDestCell.Sheet = .Sheet oDestCell.Column = .StartColumn oDestCell.Row = .StartRow End With vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", True) vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "OutputPosition", oDestCell) End If ' Define the sorting keys vSortFields = DimArray(lKeys Mod cstMaxKeys) For i = 0 To UBound(vSortFields) vSortFields(i) = New com.sun.star.table.TableSortField lKey = j * cstMaxKeys + i If lKey > UBound(SortOrder) Then sOrder = "" Else sOrder = SortOrder(lKey) If Len(sOrder) = 0 Then sOrder = "ASC" With vSortFields(i) .Field = SortKeys(lKey) - 1 .IsAscending = ( UCase(sOrder) = "ASC" ) .IsCaseSensitive = CaseSensitive End With Next i lKeys = lKeys - UBound(vSortFields) - 1 ' Associate the keys and the descriptor, and sort vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "SortFields", vSortFields) oSortRange.XCellRange.sort(vSortDescriptor) ' Next loop, if any, is done on the destination area If Len(DestinationCell) > 0 And j = lSort And lSort > 0 Then Set oSortRange = _Offset(oDestRange, 0, 0, oRangeAddress.Height, oRangeAddress.Width) Next j ' Compute the changed area If Len(DestinationCell) = 0 Then sSort = oRangeAddress.RangeName Else With oRangeAddress sSort = _Offset(oDestRange, 0, 0, .Height, .Width).RangeName End With End If Finally: SortRange = sSort ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc.SortRange REM ======================================================= SUPERCLASS PROPERTIES REM ----------------------------------------------------------------------------- Property Get CustomProperties() As Variant CustomProperties = [_Super].GetProperty("CustomProperties") End Property ' SFDocuments.SF_Calc.CustomProperties REM ----------------------------------------------------------------------------- Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant) [_Super].CustomProperties = pvCustomProperties End Property ' SFDocuments.SF_Calc.CustomProperties REM ----------------------------------------------------------------------------- Property Get Description() As Variant Description = [_Super].GetProperty("Description") End Property ' SFDocuments.SF_Calc.Description REM ----------------------------------------------------------------------------- Property Let Description(Optional ByVal pvDescription As Variant) [_Super].Description = pvDescription End Property ' SFDocuments.SF_Calc.Description REM ----------------------------------------------------------------------------- Property Get DocumentProperties() As Variant DocumentProperties = [_Super].GetProperty("DocumentProperties") End Property ' SFDocuments.SF_Calc.DocumentProperties REM ----------------------------------------------------------------------------- Property Get DocumentType() As String DocumentType = [_Super].GetProperty("DocumentType") End Property ' SFDocuments.SF_Calc.DocumentType REM ----------------------------------------------------------------------------- Property Get ExportFilters() As Variant ExportFilters = [_Super].GetProperty("ExportFilters") End Property ' SFDocuments.SF_Calc.ExportFilters REM ----------------------------------------------------------------------------- Property Get ImportFilters() As Variant ImportFilters = [_Super].GetProperty("ImportFilters") End Property ' SFDocuments.SF_Calc.ImportFilters REM ----------------------------------------------------------------------------- Property Get IsBase() As Boolean IsBase = [_Super].GetProperty("IsBase") End Property ' SFDocuments.SF_Calc.IsBase REM ----------------------------------------------------------------------------- Property Get IsCalc() As Boolean IsCalc = [_Super].GetProperty("IsCalc") End Property ' SFDocuments.SF_Calc.IsCalc REM ----------------------------------------------------------------------------- Property Get IsDraw() As Boolean IsDraw = [_Super].GetProperty("IsDraw") End Property ' SFDocuments.SF_Calc.IsDraw REM ----------------------------------------------------------------------------- Property Get IsFormDocument() As Boolean IsFormDocument = [_Super].GetProperty("IsFormDocument") End Property ' SFDocuments.SF_Writer.IsFormDocument REM ----------------------------------------------------------------------------- Property Get IsImpress() As Boolean IsImpress = [_Super].GetProperty("IsImpress") End Property ' SFDocuments.SF_Calc.IsImpress REM ----------------------------------------------------------------------------- Property Get IsMath() As Boolean IsMath = [_Super].GetProperty("IsMath") End Property ' SFDocuments.SF_Calc.IsMath REM ----------------------------------------------------------------------------- Property Get IsWriter() As Boolean IsWriter = [_Super].GetProperty("IsWriter") End Property ' SFDocuments.SF_Calc.IsWriter REM ----------------------------------------------------------------------------- Property Get Keywords() As Variant Keywords = [_Super].GetProperty("Keywords") End Property ' SFDocuments.SF_Calc.Keywords REM ----------------------------------------------------------------------------- Property Let Keywords(Optional ByVal pvKeywords As Variant) [_Super].Keywords = pvKeywords End Property ' SFDocuments.SF_Calc.Keywords REM ----------------------------------------------------------------------------- Property Get Readonly() As Variant Readonly = [_Super].GetProperty("Readonly") End Property ' SFDocuments.SF_Calc.Readonly REM ----------------------------------------------------------------------------- Property Get Subject() As Variant Subject = [_Super].GetProperty("Subject") End Property ' SFDocuments.SF_Calc.Subject REM ----------------------------------------------------------------------------- Property Let Subject(Optional ByVal pvSubject As Variant) [_Super].Subject = pvSubject End Property ' SFDocuments.SF_Calc.Subject REM ----------------------------------------------------------------------------- Property Get Title() As Variant Title = [_Super].GetProperty("Title") End Property ' SFDocuments.SF_Calc.Title REM ----------------------------------------------------------------------------- Property Let Title(Optional ByVal pvTitle As Variant) [_Super].Title = pvTitle End Property ' SFDocuments.SF_Calc.Title REM ----------------------------------------------------------------------------- Property Get XComponent() As Variant XComponent = [_Super].GetProperty("XComponent") End Property ' SFDocuments.SF_Calc.XComponent REM ========================================================== SUPERCLASS METHODS REM ----------------------------------------------------------------------------- 'Public Function Activate() As Boolean ' Activate = [_Super].Activate() 'End Function ' SFDocuments.SF_Calc.Activate REM ----------------------------------------------------------------------------- Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean CloseDocument = [_Super].CloseDocument(SaveAsk) End Function ' SFDocuments.SF_Calc.CloseDocument REM ----------------------------------------------------------------------------- Public Function CreateMenu(Optional ByVal MenuHeader As Variant _ , Optional ByVal Before As Variant _ , Optional ByVal SubmenuChar As Variant _ ) As Object Set CreateMenu = [_Super].CreateMenu(MenuHeader, Before, SubmenuChar) End Function ' SFDocuments.SF_Calc.CreateMenu REM ----------------------------------------------------------------------------- Public Sub Echo(Optional ByVal EchoOn As Variant _ , Optional ByVal Hourglass As Variant _ ) [_Super].Echo(EchoOn, Hourglass) End Sub ' SFDocuments.SF_Calc.Echo REM ----------------------------------------------------------------------------- Public Function ExportAsPDF(Optional ByVal FileName As Variant _ , Optional ByVal Overwrite As Variant _ , Optional ByVal Pages As Variant _ , Optional ByVal Password As Variant _ , Optional ByVal Watermark As Variant _ ) As Boolean ExportAsPDF = [_Super].ExportAsPDF(FileName, Overwrite, Pages, Password, Watermark) End Function ' SFDocuments.SF_Calc.ExportAsPDF REM ----------------------------------------------------------------------------- Public Function RemoveMenu(Optional ByVal MenuHeader As Variant) As Boolean RemoveMenu = [_Super].RemoveMenu(MenuHeader) End Function ' SFDocuments.SF_Calc.RemoveMenu REM ----------------------------------------------------------------------------- Public Sub RunCommand(Optional ByVal Command As Variant _ , ParamArray Args As Variant _ ) [_Super].RunCommand(Command, Args) End Sub ' SFDocuments.SF_Calc.RunCommand REM ----------------------------------------------------------------------------- Public Function Save() As Boolean Save = [_Super].Save() End Function ' SFDocuments.SF_Calc.Save REM ----------------------------------------------------------------------------- Public Function SaveAs(Optional ByVal FileName As Variant _ , Optional ByVal Overwrite As Variant _ , Optional ByVal Password As Variant _ , Optional ByVal FilterName As Variant _ , Optional ByVal FilterOptions As Variant _ ) As Boolean SaveAs = [_Super].SaveAs(FileName, Overwrite, Password, FilterName, FilterOptions) End Function ' SFDocuments.SF_Calc.SaveAs REM ----------------------------------------------------------------------------- Public Function SaveCopyAs(Optional ByVal FileName As Variant _ , Optional ByVal Overwrite As Variant _ , Optional ByVal Password As Variant _ , Optional ByVal FilterName As Variant _ , Optional ByVal FilterOptions As Variant _ ) As Boolean SaveCopyAs = [_Super].SaveCopyAs(FileName, Overwrite, Password, FilterName, FilterOptions) End Function ' SFDocuments.SF_Calc.SaveCopyAs REM ----------------------------------------------------------------------------- Public Function SetPrinter(Optional ByVal Printer As Variant _ , Optional ByVal Orientation As Variant _ , Optional ByVal PaperFormat As Variant _ ) As Boolean SetPrinter = [_Super].SetPrinter(Printer, Orientation, PaperFormat) End Function ' SFDocuments.SF_Calc.SetPrinter REM ----------------------------------------------------------------------------- Public Function Toolbars(Optional ByVal ToolbarName As Variant) As Variant Toolbars = [_Super].Toolbars(ToolbarName) End Function ' SFDocuments.SF_Calc.Toolbars REM =========================================================== PRIVATE FUNCTIONS REM ----------------------------------------------------------------------------- Private Sub _ClearRange(ByVal psTarget As String _ , Optional ByVal Range As Variant _ , Optional FilterFormula As Variant _ , Optional FilterScope As Variant _ ) ''' Clear the given range with the given options ''' The range may be filtered by a formula for a selective clearance ''' Arguments checking is done in this Sub, not in the calling one ''' Args: ''' psTarget: "All", "Formats" or "Values" ''' Range: the range to clear as a string ''' FilterFormula: a selection of cells based on a Calc formula ''' When left empty, all the cells of the range are cleared ''' psFilterScope: "CELL", "ROW" or "COLUMN" Dim lClear As Long ' A combination of com.sun.star.sheet.CellFlags Dim oRange As Object ' Alias of Range Dim vRanges() As Variant ' Array of subranges resulting from the application of the filter Dim i As Long Dim cstThisSub As String : cstThisSub = "SFDocuments.Calc.Clear" & psTarget Const cstSubArgs = "Range, [FilterFormula=""], [FilterScope=""CELL""|""ROW""|""COLUMN""]" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch Check: If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = "" If IsMissing(FilterScope) Or IsEmpty(FilterScope) Then FilterScope = "CELL" If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Range, "Range", Array(V_STRING, ScriptForge.V_OBJECT)) 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: With com.sun.star.sheet.CellFlags Select Case psTarget Case "All" lClear = .VALUE + .DATETIME + .STRING + .ANNOTATION + .FORMULA _ + .HARDATTR + .STYLES + .OBJECTS + .EDITATTR + .FORMATTED Case "Formats" lClear = .HARDATTR + .STYLES + .EDITATTR + .FORMATTED Case "Values" lClear = .VALUE + .DATETIME + .STRING + .FORMULA End Select End With If VarType(Range) = V_STRING Then Set oRange = _ParseAddress(Range) Else Set oRange = Range ' Without filter, the whole range is cleared ' Otherwise the filter cuts the range in subranges and clears them one by one If Len(FilterFormula) = 0 Then oRange.XCellRange.clearContents(lClear) Else vRanges() = _ComputeFilter(oRange, FilterFormula, UCase(FilterScope)) For i = 0 To UBound(vRanges) vRanges(i).XCellRange.clearContents(lClear) Next i End If Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Sub Catch: GoTo Finally End Sub ' SFDocuments.SF_Calc._ClearRange REM ----------------------------------------------------------------------------- Private Function _ComputeFilter(ByRef poRange As Object _ , ByVal psFilterFormula As String _ , ByVal psFilterScope As String _ ) As Variant ''' Compute in the given range the cells, rows or columns for which ''' the given formula returns TRUE ''' Args: ''' poRange: the range on which to compute the filter as an _Address type ''' psFilterFormula: the formula to be applied on each row, column or cell ''' psFilterSCope: "ROW", "COLUMN" or "CELL" ''' Returns: ''' An array of ranges as objects of type _Address Dim vRanges As Variant ' Return value Dim oRange As Object ' A single vRanges() item Dim lLast As Long ' Last used row or column number in the sheet containing Range Dim oFormulaRange As _Address ' Range where the FilterFormula must be stored Dim sFormulaDirection As String ' Either V(ertical), H(orizontal) or B(oth) Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property Dim vFilter As Variant ' Array of Boolean values indicating which rows should be erased Dim bFilter As Boolean ' A single item in vFilter Dim iDims As Integer ' Number of dimensions of vFilter() Dim lLower As Long ' Lower level of contiguous True filter values Dim lUpper As Long ' Upper level of contiguous True filter values Dim i As Long, j As Long Check: ' Error handling is determined by the calling method vRanges = Array() Try: With poRange ' Compute the range where to apply the formula ' Determine the direction of the range containing the formula vertical, horizontal or both Select Case psFilterScope Case "ROW" lLast = LastColumn(.SheetName) ' Put formulas as a single column in the unused area at the right of the range to filter Set oFormulaRange = _Offset(poRange, 0, lLast - .XCellRange.RangeAddress.StartColumn + 1, 0, 1) sFormulaDirection = "V" Case "COLUMN" lLast = LastRow(.SheetName) ' Put formulas as a single row in the unused area at the bottom of the range to filter Set oFormulaRange = _Offset(poRange, lLast - .XCellRange.RangeAddress.StartRow + 1, 0, 1, 0) sFormulaDirection = "H" Case "CELL" lLast = LastRow(.SheetName) ' Put formulas as a matrix in the unused area at the bottom of the range to filter Set oFormulaRange = _Offset(poRange, lLast - .XCellRange.RangeAddress.StartRow + 1, 0, 0, 0) sFormulaDirection = "B" If oFormulaRange.Width = 1 Then sFormulaDirection = "V" ElseIf oFormulaRange.Height = 1 Then sFormulaDirection = "H" End If End Select ' Apply the formula and get the result as an array of Boolean values. Clean up SetFormula(oFormulaRange, psFilterFormula) vDataArray = oFormulaRange.XCellRange.getDataArray() vFilter = _ConvertFromDataArray(vDataArray) iDims = ScriptForge.SF_Array.CountDims(vFilter) ClearAll(oFormulaRange) ' Convert the filter values (0 = False, 1 = True) to a set of ranges Select Case iDims Case -1 ' Scalar If vFilter = 1 Then vRanges = ScriptForge.SF_Array.Append(vRanges, poRange) Case 0 ' Empty array ' Nothing to do Case 1, 2 ' Vector or Array ' Strategy: group contiguous applicable rows/columns to optimize heavy operations like CompactUp, CompactLeft ' Stack the contiguous ranges of True values in vRanges() ' To manage vector and array with same code, setup a single fictitious loop when vector, otherwise scan array by row For i = 0 To Iif(iDims = 1, 0, UBound(vFilter, 1)) lLower = -1 : lUpper = -1 For j = 0 To UBound(vFilter, iDims) If iDims = 1 Then bFilter = CBool(vFilter(j)) Else bFilter = CBool(vFilter(i, j)) If j = UBound(vFilter, iDims) And bFilter Then ' Don't forget the last item If lLower < 0 Then lLower = j lUpper = j ElseIf Not bFilter Then If lLower >= 0 Then lUpper = j - 1 ElseIf bFilter Then If lLower < 0 Then lLower = j End If ' Determine the next applicable range when one found and limit reached If lUpper > -1 Then If sFormulaDirection = "V" Then ' ROW Set oRange = _Offset(poRange, lLower, 0, lUpper - lLower + 1, 0) ElseIf sFormulaDirection = "H" Then ' COLUMN Set oRange = _Offset(poRange, 0, lLower, 0, lUpper - lLower + 1) Else ' CELL Set oRange = _Offset(poRange, i, lLower, 1, lUpper - lLower + 1) End If If Not IsNull(oRange) Then vRanges = ScriptForge.SF_Array.Append(vRanges, oRange) lLower = -1 : lUpper = -1 End If Next j Next i Case Else ' Should not happen End Select End With Finally: _ComputeFilter = vRanges() Exit Function End Function ' SFDocuments.SF_Calc._ComputeFilter REM ----------------------------------------------------------------------------- Public Function _ConvertFromDataArray(ByRef pvDataArray As Variant) As Variant ''' Convert a data array to a scalar, a vector or a 2D array ''' Args: ''' pvDataArray: an array as returned by the XCellRange.getDataArray or .getFormulaArray methods ''' Returns: ''' A scalar, a zero-based 1D array or a zero-based 2D array of strings and/or doubles ''' To convert doubles to dates, use the CDate builtin function Dim vArray As Variant ' Return value Dim lMax1 As Long ' UBound of pvDataArray Dim lMax2 As Long ' UBound of pvDataArray items Dim i As Long Dim j As Long vArray = Empty Try: ' Convert the data array to scalar, vector or array lMax1 = UBound(pvDataArray) If lMax1 >= 0 Then lMax2 = UBound(pvDataArray(0)) If lMax2 >= 0 Then If lMax1 + lMax2 > 0 Then vArray = Array() Select Case True Case lMax1 = 0 And lMax2 = 0 ' Scalar vArray = pvDataArray(0)(0) Case lMax1 > 0 And lMax2 = 0 ' Vertical vector ReDim vArray(0 To lMax1) For i = 0 To lMax1 vArray(i) = pvDataArray(i)(0) Next i Case lMax1 = 0 And lMax2 > 0 ' Horizontal vector ReDim vArray(0 To lMax2) For j = 0 To lMax2 vArray(j) = pvDataArray(0)(j) Next j Case Else ' Array ReDim vArray(0 To lMax1, 0 To lMax2) For i = 0 To lMax1 For j = 0 To lMax2 vArray(i, j) = pvDataArray(i)(j) Next j Next i End Select End If End If Finally: _ConvertFromDataArray = vArray End Function ' SFDocuments.SF_Calc._ConvertFromDataArray REM ----------------------------------------------------------------------------- Private Function _ConvertToCellValue(ByVal pvItem As Variant) As Variant ''' Convert the argument to a valid Calc cell content Dim vCell As Variant ' Return value Try: Select Case ScriptForge.SF_Utils._VarTypeExt(pvItem) Case V_STRING : vCell = pvItem Case V_DATE : vCell = CDbl(pvItem) Case ScriptForge.V_NUMERIC : vCell = CDbl(pvItem) Case ScriptForge.V_BOOLEAN : vCell = CDbl(Iif(pvItem, 1, 0)) Case Else : vCell = "" End Select Finally: _ConvertToCellValue = vCell Exit Function End Function ' SFDocuments.SF_Calc._ConvertToCellValue REM ----------------------------------------------------------------------------- Private Function _ConvertToDataArray(ByRef pvArray As Variant _ , Optional ByVal plRows As Long _ , Optional ByVal plColumns As Long _ ) As Variant ''' Create a 2-dimensions nested array (compatible with the ranges .DataArray property) ''' from a scalar, a 1D array or a 2D array ''' Input may be a 1D array of arrays, typically when call issued by a Python script ''' Array items are converted to (possibly empty) strings or doubles ''' Args: ''' pvArray: the input scalar or array. If array, must be 1 or 2D otherwise it is ignored. ''' plRows, plColumns: the upper bounds of the data array ''' If bigger than input array, fill with zero-length strings ''' If smaller than input array, truncate ''' If plRows = 0 and the input array is a vector, the data array is aligned horizontally ''' They are either both present or both absent ''' When absent ''' The size of the output is fully determined by the input array ''' Vectors are aligned vertically ''' Returns: ''' A data array compatible with ranges .DataArray property ''' The output is always an array of nested arrays Dim vDataArray() As Variant ' Return value Dim vVector() As Variant ' A temporary 1D array Dim vItem As Variant ' A single input item Dim iDims As Integer ' Number of dimensions of the input argument Dim lMin1 As Long ' Lower bound (1) of input array Dim lMax1 As Long ' Upper bound (1) Dim lMin2 As Long ' Lower bound (2) Dim lMax2 As Long ' Upper bound (2) Dim lRows As Long ' Upper bound of vDataArray Dim lCols As Long ' Upper bound of vVector Dim bHorizontal As Boolean ' Horizontal vector Dim bDataArray As Boolean ' Input array is already an array of arrays Dim i As Long Dim j As Long Const cstEmpty = "" ' Empty cell If IsMissing(plRows) Or IsEmpty(plRows) Then plRows = -1 If IsMissing(plColumns) Or IsEmpty(plColumns) Then plColumns = -1 vDataArray = Array() Try: ' Check the input argument and know its boundaries iDims = ScriptForge.SF_Array.CountDims(pvArray) If iDims = 0 Or iDims > 2 Then Exit Function lMin1 = 0 : lMax1 = 0 ' Default values lMin2 = 0 : lMax2 = 0 Select Case iDims Case -1 ' Scalar value Case 1 bHorizontal = ( plRows = 0 And plColumns > 0 ) bDataArray = IsArray(pvArray(0)) If Not bDataArray Then If Not bHorizontal Then lMin1 = LBound(pvArray) : lMax1 = UBound(pvArray) Else lMin2 = LBound(pvArray) : lMax2 = UBound(pvArray) End If Else iDims = 2 lMin1 = LBound(pvArray) : lMax1 = UBound(pvArray) lMin2 = LBound(pvArray(0)) : lMax2 = UBound(pvArray(0)) End If Case 2 lMin1 = LBound(pvArray, 1) : lMax1 = UBound(pvArray, 1) lMin2 = LBound(pvArray, 2) : lMax2 = UBound(pvArray, 2) End Select ' Set the output dimensions accordingly If plRows >= 0 Then ' Dimensions of output are imposed lRows = plRows lCols = plColumns Else ' Dimensions of output determined by input argument lRows = 0 : lCols = 0 ' Default values Select Case iDims Case -1 ' Scalar value Case 1 ' Vectors are aligned vertically lRows = lMax1 - lMin1 Case 2 lRows = lMax1 - lMin1 lCols = lMax2 - lMin2 End Select End If ReDim vDataArray(0 To lRows) ' Feed the output array row by row, each row being a vector For i = 0 To lRows ReDim vVector(0 To lCols) For j = 0 To lCols If i > lMax1 - lMin1 Then vVector(j) = cstEmpty ElseIf j > lMax2 - lMin2 Then vVector(j) = cstEmpty Else Select Case iDims Case -1 : vItem = _ConvertToCellValue(pvArray) Case 1 If bHorizontal Then vItem = _ConvertToCellValue(pvArray(j + lMin2)) Else vItem = _ConvertToCellValue(pvArray(i + lMin1)) End If Case 2 If bDataArray Then vItem = _ConvertToCellValue(pvArray(i + lMin1)(j + lMin2)) Else vItem = _ConvertToCellValue(pvArray(i + lMin1, j + lMin2)) End If End Select vVector(j) = vItem End If vDataArray(i) = vVector Next j Next i Finally: _ConvertToDataArray = vDataArray Exit Function End Function ' SFDocuments.SF_Calc._ConvertToDataArray REM ----------------------------------------------------------------------------- Private Function _DFunction(ByVal psFunction As String _ , Optional ByVal Range As Variant _ ) As Double ''' Apply the given function on all the numeric values stored in the given range ''' Args: ''' Range : the range as a string where to apply the function on ''' Returns: ''' The resulting value as a double Dim dblGet As Double ' Return value Dim oAddress As Object ' Alias of Range Dim vFunction As Variant ' com.sun.star.sheet.GeneralFunction.XXX Dim cstThisSub As String : cstThisSub = "SFDocuments.Calc." & psFunction Const cstSubArgs = "Range" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch dblGet = 0 Check: If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not _IsStillAlive() Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(Range, "Range", V_STRING) Then GoTo Finally End If Try: ' Get the data Set oAddress = _ParseAddress(Range) Select Case psFunction Case "DAvg" : vFunction = com.sun.star.sheet.GeneralFunction.AVERAGE Case "DCount" : vFunction = com.sun.star.sheet.GeneralFunction.COUNTNUMS Case "DMax" : vFunction = com.sun.star.sheet.GeneralFunction.MAX Case "DMin" : vFunction = com.sun.star.sheet.GeneralFunction.MIN Case "DSum" : vFunction = com.sun.star.sheet.GeneralFunction.SUM Case Else : GoTo Finally End Select dblGet = oAddress.XCellRange.computeFunction(vFunction) Finally: _DFunction = dblGet ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SFDocuments.SF_Calc._DFunction REM ----------------------------------------------------------------------------- Private Function _FileIdent() As String ''' Returns a file identification from the information that is currently available ''' Useful e.g. for display in error messages _FileIdent = [_Super]._FileIdent() End Function ' SFDocuments.SF_Calc._FileIdent REM ----------------------------------------------------------------------------- Function _GetColumnName(ByVal plColumnNumber As Long) As String ''' Convert a column number (range 1, 2,..16384) into its letter counterpart (range 'A', 'B',..'XFD'). ''' Args: ''' ColumnNumber: the column number, must be in the interval 1 ... 16384 ''' Returns: ''' a string representation of the column name, in range 'A'..'XFD' ''' Adapted from a Python function by sundar nataraj ''' http://stackoverflow.com/questions/23861680/convert-spreadsheet-number-to-column-letter Dim sCol As String ' Return value Dim lDiv As Long ' Intermediate result Dim lMod As Long ' Result of modulo 26 operation Try: sCol = "" lDiv = plColumnNumber Do While lDiv > 0 lMod = (lDiv - 1) Mod 26 sCol = Chr(65 + lMod) & sCol lDiv = (lDiv - lMod) \ 26 Loop Finally: _GetColumnName = sCol End Function ' SFDocuments.SF_Calc._GetColumnName REM ----------------------------------------------------------------------------- Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _ , Optional ByVal pbError As Boolean _ ) As Boolean ''' Returns True if the document has not been closed manually or incidentally since the last use ''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default) ''' Args: ''' pbForUpdate: if True (default = False), check additionally if document is open for editing ''' pbError: if True (default), raise a fatal error Dim bAlive As Boolean ' Return value If IsMissing(pbForUpdate) Then pbForUpdate = False If IsMissing(pbError) Then pbError = True Try: bAlive = [_Super]._IsStillAlive(pbForUpdate, pbError) Finally: _IsStillAlive = bAlive Exit Function End Function ' SFDocuments.SF_Calc._IsStillAlive REM ----------------------------------------------------------------------------- Private Function _LastCell(ByRef poSheet As Object) As Variant ''' Returns in an array the coordinates of the last used cell in the given sheet Dim oCursor As Object ' Cursor on the cell Dim oRange As Object ' The used range Dim vCoordinates(0 To 1) As Long ' Return value: (0) = Column, (1) = Row Try: Set oCursor = poSheet.createCursorByRange(poSheet.getCellRangeByName("A1")) oCursor.gotoEndOfUsedArea(True) Set oRange = poSheet.getCellRangeByName(oCursor.AbsoluteName) vCoordinates(0) = oRange.RangeAddress.EndColumn + 1 vCoordinates(1) = oRange.RangeAddress.EndRow + 1 Finally: _LastCell = vCoordinates End Function ' SFDocuments.SF_Calc._LastCell REM ----------------------------------------------------------------------------- Public Function _Offset(ByRef pvRange As Variant _ , ByVal plRows As Long _ , ByVal plColumns As Long _ , ByVal plHeight As Long _ , ByVal plWidth As Long _ ) As Object ''' Returns a new range offset by a certain number of rows and columns from a given range ''' Args: ''' pvRange : the range, as a string or an object, from which the function searches for the new range ''' plRows : the number of rows by which the reference was corrected up (negative value) or down. ''' plColumns : the number of columns by which the reference was corrected to the left (negative value) or to the right. ''' plHeight : the vertical height for an area that starts at the new reference position. ''' plWidth : the horizontal width for an area that starts at the new reference position. ''' Arguments Rows and Columns must not lead to zero or negative start row or column. ''' Arguments Height and Width must not lead to zero or negative count of rows or columns. ''' Returns: ''' A new range as object of type _Address ''' Exceptions: ''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries Dim oOffset As Object ' Return value Dim oAddress As Object ' Alias of Range Dim oSheet As Object ' com.sun.star.sheet.XSpreadsheet Dim oRange As Object ' com.sun.star.table.XCellRange Dim oNewRange As Object ' com.sun.star.table.XCellRange Dim lLeft As Long ' New range coordinates Dim lTop As Long Dim lRight As Long Dim lBottom As Long Set oOffset = Nothing Check: If plHeight < 0 Or plWidth < 0 Then GoTo CatchAddress Try: If VarType(pvRange) = V_STRING Then Set oAddress = _ParseAddress(pvRange) Else Set oAddress = pvRange Set oSheet = oAddress.XSpreadSheet Set oRange = oAddress.XCellRange.RangeAddress ' Compute and validate new coordinates With oRange lLeft = .StartColumn + plColumns lTop = .StartRow + plRows lRight = lLeft + Iif(plWidth = 0, .EndColumn - .StartColumn, plWidth - 1) lBottom = lTop + Iif(plHeight = 0, .EndRow - .StartRow, plHeight - 1) If lLeft < 0 Or lRight < 0 Or lTop < 0 Or lBottom < 0 _ Or lLeft >= MAXCOLS Or lRight >= MAXCOLS _ Or lTop >= MAXROWS Or lBottom >= MAXROWS _ Then GoTo CatchAddress Set oNewRange = oSheet.getCellRangeByPosition(lLeft, lTop, lRight, lBottom) End With ' Define the new range address Set oOffset = New _Address With oOffset .ObjectType = CALCREFERENCE .ServiceName = SERVICEREFERENCE .RawAddress = oNewRange.AbsoluteName .Component = _Component .XSpreadsheet = oNewRange.Spreadsheet .SheetName = .XSpreadsheet.Name .SheetIndex = .XSpreadsheet.RangeAddress.Sheet .RangeName = .RawAddress .XCellRange = oNewRange .Height = oNewRange.RangeAddress.EndRow - oNewRange.RangeAddress.StartRow + 1 .Width = oNewRange.RangeAddress.EndColumn - oNewRange.RangeAddress.StartColumn + 1 End With Finally: Set _Offset = oOffset Exit Function Catch: GoTo Finally CatchAddress: ScriptForge.SF_Exception.RaiseFatal(OFFSETADDRESSERROR, "Range", oAddress.RawAddress _ , "Rows", plRows, "Columns", plColumns, "Height", plHeight, "Width", plWidth _ , "Document", [_Super]._FileIdent()) GoTo Finally End Function ' SFDocuments.SF_Calc._Offset REM ----------------------------------------------------------------------------- Private Function _ParseAddress(ByVal psAddress As String) As Object ''' Parse and validate a sheet or range reference ''' Syntax to parse: ''' [Sheet].[Range] ''' Sheet => [$][']sheet['] or document named range or ~ ''' Range => A1:D10, A1, A:D, 10:10 ($ ignored), or sheet named range or ~ or * ''' Returns: ''' An object of type _Address ''' Exceptions: ''' CALCADDRESSERROR ' Address could not be parsed to a valid address Dim oAddress As Object ' Return value Dim sAddress As String ' Alias of psAddress Dim vRangeName As Variant ' Array Sheet/Range Dim lStart As Long ' Position of found regex Dim sSheet As String ' Sheet component Dim sRange As String ' Range component Dim oSheets As Object ' com.sun.star.sheet.XSpreadsheets Dim oNamedRanges As Object ' com.sun.star.sheet.XNamedRanges Dim oRangeAddress As Object ' Alias for rangeaddress Dim vLastCell As Variant ' Result of _LastCell() method Dim oSelect As Object ' Current selection ' If psAddress has already been parsed, get the result back If Not IsNull(_LastParsedAddress) Then ' Given argument must contain an explicit reference to a sheet If (InStr(psAddress, "~.") = 0 And InStr(psAddress, ".") > 0 And psAddress = _LastParsedAddress.RawAddress) _ Or psAddress = _LastParsedAddress.RangeName Then Set _ParseAddress = _LastParsedAddress Exit Function Else Set _LastParsedAddress = Nothing End If End If ' Reinitialize a new _Address object Set oAddress = New _Address With oAddress sSheet = "" : sRange = "" .SheetName = "" : .RangeName = "" .ObjectType = CALCREFERENCE .ServiceName = SERVICEREFERENCE .RawAddress = psAddress Set .XSpreadSheet = Nothing : Set .XCellRange = Nothing ' Remove leading "$' when followed with an apostrophe If Left(psAddress, 2) = "$'" Then sAddress = Mid(psAddress, 2) Else sAddress = psAddress ' Split in sheet and range components on dot not enclosed in single quotes vRangeName = ScriptForge.SF_String.SplitNotQuoted(sAddress, Delimiter := ".", QuoteChar := "'") sSheet = ScriptForge.SF_String.Unquote(Replace(vRangeName(0), "''", "\'"), QuoteChar := "'") ' Keep a leading "$" in the sheet name only if name enclosed in single quotes ' Notes: ' sheet names may contain "$" (even "$" is a valid sheet name), named ranges must not ' sheet names may contain apostrophes (except in 1st and last positions), range names must not If Left(vRangeName(0), 2) <> "'$" And Left(sSheet, 1) = "$" And Len(sSheet) > 1 Then sSheet = Mid(sSheet, 2) If UBound(vRangeName) > 0 Then sRange = vRangeName(1) ' Resolve sheet part: either a document named range, or the active sheet or a real sheet Set oSheets = _Component.getSheets() Set oNamedRanges = _Component.NamedRanges If oSheets.hasByName(sSheet) Then ElseIf sSheet = "~" And Len(sRange) > 0 Then sSheet = _Component.CurrentController.ActiveSheet.Name ElseIf oNamedRanges.hasByName(sSheet) Then .XCellRange = oNamedRanges.getByName(sSheet).ReferredCells sSheet = oSheets.getByIndex(oNamedRanges.getByName(sSheet).ReferencePosition.Sheet).Name Else sRange = sSheet sSheet = _Component.CurrentController.ActiveSheet.Name End If .SheetName = sSheet .XSpreadSheet = oSheets.getByName(sSheet) .SheetIndex = .XSpreadSheet.RangeAddress.Sheet ' Resolve range part - either a sheet named range or the current selection or a real range or "" If IsNull(.XCellRange) Then Set oNamedRanges = .XSpreadSheet.NamedRanges If sRange = "~" Then Set oSelect = _Component.CurrentController.getSelection() If oSelect.supportsService("com.sun.star.sheet.SheetCellRanges") Then ' Multiple selections Set .XCellRange = oSelect.getByIndex(0) Else Set .XCellRange = oSelect End If ElseIf sRange = "*" Or sRange = "" Then vLastCell = _LastCell(.XSpreadSheet) sRange = "A1:" & _GetColumnName(vLastCell(0)) & CStr(vLastCell(1)) Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) ElseIf oNamedRanges.hasByName(sRange) Then .XCellRange = oNamedRanges.getByName(sRange).ReferredCells Else On Local Error GoTo CatchError Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) ' If range reaches the limits of the sheets, reduce it up to the used area Set oRangeAddress = .XCellRange.RangeAddress If oRangeAddress.StartColumn = 0 And oRangeAddress.EndColumn = MAXCOLS - 1 Then vLastCell = _LastCell(.XSpreadSheet) sRange = "A" & CStr(oRangeAddress.StartRow + 1) & ":" _ & _GetColumnName(vLastCell(0)) & CStr(oRangeAddress.EndRow + 1) Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) ElseIf oRangeAddress.StartRow = 0 And oRangeAddress.EndRow = MAXROWS - 1 Then vLastCell = _LastCell(.XSpreadSheet) sRange = _GetColumnName(oRangeAddress.StartColumn + 1) & "1" & ":" _ & _GetColumnName(oRangeAddress.EndColumn + 1) & CStr(_LastCell(.XSpreadSheet)(1)) Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange) End If End If End If If IsNull(.XCellRange) Then GoTo CatchAddress Set oRangeAddress = .XCellRange.RangeAddress .RangeName = .XCellRange.AbsoluteName .Height = oRangeAddress.EndRow - oRangeAddress.StartRow + 1 .Width = oRangeAddress.EndColumn - oRangeAddress.StartColumn + 1 ' Remember the current component in case of use outside the current instance Set .Component = _Component End With ' Store last parsed address for reuse Set _LastParsedAddress = oAddress Finally: Set _ParseAddress = oAddress Exit Function CatchError: ScriptForge.SF_Exception.Clear() CatchAddress: ScriptForge.SF_Exception.RaiseFatal(CALCADDRESSERROR, "Range", psAddress _ , "Document", [_Super]._FileIdent()) GoTo Finally End Function ' SFDocuments.SF_Calc._ParseAddress REM ----------------------------------------------------------------------------- Private Function _PropertyGet(Optional ByVal psProperty As String _ , Optional ByVal pvArg As Variant _ ) As Variant ''' Return the value of the named property ''' Args: ''' psProperty: the name of the property Dim oProperties As Object ' Document or Custom properties Dim vLastCell As Variant ' Coordinates of last used cell in a sheet Dim oSelect As Object ' Current selection Dim vRanges As Variant ' List of selected ranges Dim oAddress As Object ' _Address type for range description Dim oCursor As Object ' com.sun.star.sheet.XSheetCellCursor Dim i As Long Dim cstThisSub As String Const cstSubArgs = "" _PropertyGet = False cstThisSub = "SFDocuments.Calc.get" & psProperty ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) If Not _IsStillAlive() Then GoTo Finally Select Case UCase(psProperty) Case UCase("CurrentSelection") Set oSelect = _Component.CurrentController.getSelection() If IsNull(oSelect) Then _PropertyGet = Array() ElseIf oSelect.supportsService("com.sun.star.sheet.SheetCellRanges") Then ' Multiple selections vRanges = Array() For i = 0 To oSelect.Count - 1 vRanges = ScriptForge.SF_Array.Append(vRanges, oSelect.getByIndex(i).AbsoluteName) Next i _PropertyGet = vRanges Else _PropertyGet = oSelect.AbsoluteName End If Case UCase("Height") If IsMissing(pvArg) Or IsEmpty(pvArg) Then _PropertyGet = 0 Else If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally _PropertyGet = _ParseAddress(pvArg).Height End If Case UCase("FirstCell"), UCase("FirstRow"), UCase("FirstColumn") _ , UCase("LastCell"), UCase("LastColumn"), UCase("LastRow") _ , UCase("SheetName") If IsMissing(pvArg) Or IsEmpty(pvArg) Then ' Avoid errors when instance is watched in Basic IDE If InStr(UCase(psProperty), "CELL") > 0 Then _PropertyGet = "" Else _PropertyGet = -1 Else If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally Set oAddress = _ParseAddress(pvArg) With oAddress.XCellRange Select Case UCase(psProperty) Case UCase("FirstCell") _PropertyGet = A1Style(.RangeAddress.StartRow + 1, .RangeAddress.StartColumn + 1, , , oAddress.XSpreadsheet.Name) Case UCase("FirstColumn") : _PropertyGet = CLng(.RangeAddress.StartColumn + 1) Case UCase("FirstRow") : _PropertyGet = CLng(.RangeAddress.StartRow + 1) Case UCase("LastCell") _PropertyGet = A1Style(.RangeAddress.EndRow + 1, .RangeAddress.EndColumn + 1, , , oAddress.XSpreadsheet.Name) Case UCase("LastColumn") : _PropertyGet = CLng(.RangeAddress.EndColumn + 1) Case UCase("LastRow") : _PropertyGet = CLng(.RangeAddress.EndRow + 1) Case UCase("SheetName") : _PropertyGet = oAddress.XSpreadsheet.Name End Select End With End If Case UCase("Range") If IsMissing(pvArg) Or IsEmpty(pvArg) Then Set _PropertyGet = Nothing Else If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally Set _PropertyGet = _ParseAddress(pvArg) End If Case UCase("Region") If IsMissing(pvArg) Or IsEmpty(pvArg) Then _PropertyGet = "" Else If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally Set oAddress = _ParseAddress(pvArg) With oAddress Set oCursor = .XSpreadsheet.createCursorByRange(.XCellRange) oCursor.collapseToCurrentRegion() _PropertyGet = oCursor.AbsoluteName End With End If Case UCase("Sheet") If IsMissing(pvArg) Or IsEmpty(pvArg) Then Set _PropertyGet = Nothing Else If Not _ValidateSheet(pvArg, "SheetName", , True) Then GoTo Finally Set _PropertyGet = _ParseAddress(pvArg) End If Case UCase("Sheets") _PropertyGet = _Component.getSheets.getElementNames() Case UCase("Width") If IsMissing(pvArg) Or IsEmpty(pvArg) Then _PropertyGet = 0 Else If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally _PropertyGet = _ParseAddress(pvArg).Width End If Case UCase("XCellRange") If IsMissing(pvArg) Or IsEmpty(pvArg) Then Set _PropertyGet = Nothing Else If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally Set _PropertyGet = _ParseAddress(pvArg).XCellRange End If Case UCase("XSheetCellCursor") If IsMissing(pvArg) Or IsEmpty(pvArg) Then Set _PropertyGet = Nothing Else If Not ScriptForge.SF_Utils._Validate(pvArg, "Range", V_STRING) Then GoTo Finally Set oAddress = _ParseAddress(pvArg) Set _PropertyGet = oAddress.XSpreadsheet.createCursorByRange(oAddress.XCellRange) End If Case UCase("XSpreadsheet") If IsMissing(pvArg) Or IsEmpty(pvArg) Then Set _PropertyGet = Nothing Else If Not _ValidateSheet(pvArg, "SheetName", , True) Then GoTo Finally Set _PropertyGet = _Component.getSheets.getByName(pvArg) End If Case Else _PropertyGet = Null End Select Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function End Function ' SFDocuments.SF_Calc._PropertyGet REM ----------------------------------------------------------------------------- Private Function _QuoteSheetName(ByVal psSheetName As String) As String ''' Return the given sheet name surrounded with single quotes ''' when required to insert the sheet name into a Calc formula ''' Enclosed single quotes are doubled ''' Args: ''' psSheetName: the name to quote ''' Returns: ''' The quoted or unchanged sheet name Dim sSheetName As String ' Return value Dim i As Long Try: ' Surround the sheet name with single quotes when required by the presence of single quotes If InStr(psSheetName, "'") > 0 Then sSheetName = "'" & Replace(psSheetName, "'", "''") & "'" Else ' Surround the sheet name with single quotes when required by the presence of at least one of the special characters sSheetName = psSheetName For i = 1 To Len(cstSPECIALCHARS) If InStr(sSheetName, Mid(cstSPECIALCHARS, i, 1)) > 0 Then sSheetName = "'" & sSheetName & "'" Exit For End If Next i End If Finally: _QuoteSheetName = sSheetName Exit Function End Function ' SFDocuments.SF_Calc._QuoteSheetName REM ----------------------------------------------------------------------------- Private Function _Repr() As String ''' Convert the SF_Calc instance to a readable string, typically for debugging purposes (DebugPrint ...) ''' Args: ''' Return: ''' "[DOCUMENT]: Type/File" _Repr = "[Calc]: " & [_Super]._FileIdent() End Function ' SFDocuments.SF_Calc._Repr REM ----------------------------------------------------------------------------- Private Sub _RestoreSelections(ByRef pvComponent As Variant _ , ByRef pvSelection As Variant _ ) ''' Set the selection to a single or a multiple range ''' Does not work well when multiple selections and macro terminating in Basic IDE ''' Called by the CopyToCell and CopyToRange methods ''' Args: ''' pvComponent: should work for foreign instances as well ''' pvSelection: the stored selection done previously by Component.CurrentController.getSelection() Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress Dim i As Long Try: If IsArray(pvSelection) Then Set oCellRanges = pvComponent.createInstance("com.sun.star.sheet.SheetCellRanges") vRangeAddresses = Array() ReDim vRangeAddresses(0 To UBound(pvSelection)) For i = 0 To UBound(pvSelection) vRangeAddresses(i) = pvSelection.getByIndex(i).RangeAddress Next i oCellRanges.addRangeAddresses(vRangeAddresses, False) pvComponent.CurrentController.select(oCellRanges) Else pvComponent.CurrentController.select(pvSelection) End If Finally: Exit Sub End Sub ' SFDocuments.SF_Calc._RestoreSelections REM ----------------------------------------------------------------------------- Private Function _ValidateSheet(Optional ByRef pvSheetName As Variant _ , Optional ByVal psArgName As String _ , Optional ByVal pvNew As Variant _ , Optional ByVal pvActive As Variant _ , Optional ByVal pvOptional as Variant _ , Optional ByVal pvNumeric As Variant _ , Optional ByVal pvReference As Variant _ , Optional ByVal pvResetSheet As Variant _ ) As Boolean ''' Sheet designation validation function similar to the SF_Utils._ValidateXXX functions ''' Args: ''' pvSheetName: string or numeric position ''' pvArgName: the name of the variable to be used in the error message ''' pvNew: if True, sheet must not exist (default = False) ''' pvActive: if True, the shortcut "~" is accepted (default = False) ''' pvOptional: if True, a zero-length string is accepted (default = False) ''' pvNumeric: if True, the sheet position is accepted (default = False) ''' pvReference: if True, a sheet reference is acceptable (default = False) ''' pvNumeric and pvReference must not both be = True ''' pvResetSheet: if True, return in pvSheetName the correct (case-sensitive) sheet name (default = False) ''' Returns ''' True if valid. SheetName is reset to current value if = "~" ''' Exceptions ''' DUPLICATESHEETERROR A sheet with the given name exists already Dim vSheets As Variant ' List of sheets Dim lSheet As Long ' Index in list of sheets Dim vTypes As Variant ' Array of accepted variable types Dim bValid As Boolean ' Return value Check: If IsMissing(pvNew) Or IsEmpty(pvNew) Then pvNew = False If IsMissing(pvActive) Or IsEmpty(pvActive) Then pvActive = False If IsMissing(pvOptional) Or IsEmpty(pvOptional) Then pvOptional = False If IsMissing(pvNumeric) Or IsEmpty(pvNumeric) Then pvNumeric = False If IsMissing(pvReference) Or IsEmpty(pvReference) Then pvReference = False If IsMissing(pvResetSheet) Or IsEmpty(pvResetSheet) Then pvResetSheet = False ' Define the acceptable variable types If pvNumeric Then vTypes = Array(V_STRING, V_NUMERIC) ElseIf pvReference Then vTypes = Array(V_STRING, ScriptForge.V_OBJECT) Else vTypes = V_STRING End If If Not ScriptForge.SF_Utils._Validate(pvSheetName, psArgName, vTypes, , , Iif(pvReference, CALCREFERENCE, "")) Then GoTo Finally bValid = False Try: If VarType(pvSheetName) = V_STRING Then If pvOptional And Len(pvSheetName) = 0 Then ElseIf pvActive And pvSheetName = "~" Then pvSheetName = _Component.CurrentController.ActiveSheet.Name Else vSheets = _Component.getSheets.getElementNames() If pvNew Then ' ScriptForge.SF_String.FindRegex(sAddress, "^'[^\[\]*?:\/\\]+'") If ScriptForge.SF_Array.Contains(vSheets, pvSheetName) Then GoTo CatchDuplicate Else If Not ScriptForge.SF_Utils._Validate(pvSheetName, psArgName, V_STRING, vSheets) Then GoTo Finally If pvResetSheet Then lSheet = ScriptForge.SF_Array.IndexOf(vSheets, pvSheetName, CaseSensitive := False) pvSheetName = vSheets(lSheet) End If End If End If End If bValid = True Finally: _ValidateSheet = bValid Exit Function CatchDuplicate: ScriptForge.SF_Exception.RaiseFatal(DUPLICATESHEETERROR, psArgName, pvSheetName, "Document", [_Super]._FileIdent()) GoTo Finally End Function ' SFDocuments.SF_Calc._ValidateSheet REM ----------------------------------------------------------------------------- Private Function _ValidateSheetName(ByRef psSheetName As String _ , ByVal psArgName As String _ ) As Boolean ''' Check the validity of the sheet name: ''' A sheet name - must not be empty ''' - must not contain next characters: []*?:/\ ''' - must not use ' (the apostrophe) as first or last character ''' Args: ''' psSheetName: the name to check ''' psArgName: the name of the argument to appear in error messages ''' Returns: ''' True when the sheet name is valid ''' Exceptions: ''' CALCADDRESSERROR ' Sheet name could not be parsed to a valid name Dim bValid As Boolean ' Return value Try: bValid = ( Len(psSheetName) > 0 ) If bValid Then bValid = ( Left(psSheetName, 1) <> "'" And Right(psSheetName, 1) <> "'" ) If bValid Then bValid = ( Len(ScriptForge.SF_String.FindRegex(psSheetName, "^[^\[\]*?:\/\\]+$", 1, CaseSensitive := False)) > 0 ) If Not bValid Then GoTo CatchSheet Finally: _ValidateSheetName = bValid Exit Function CatchSheet: ScriptForge.SF_Exception.RaiseFatal(CALCADDRESSERROR, psArgName, psSheetName _ , "Document", [_Super]._FileIdent()) GoTo Finally End Function ' SFDocuments.SF_Calc._ValidateSheetName REM ============================================ END OF SFDOCUMENTS.SF_CALC