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 ''' ''' 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 ''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 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" REM ============================================================= PRIVATE MEMBERS Private [Me] As Object Private [_Parent] 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 REM ============================================================ MODULE CONSTANTS Private Const cstSHEET = 1 Private Const cstRANGE = 2 Private Const MAXCOLS = 2^10 ' 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 REM ====================================================== CONSTRUCTOR/DESTRUCTOR REM ----------------------------------------------------------------------------- Private Sub Class_Initialize() Set [Me] = Nothing Set [_Parent] = Nothing Set [_Super] = Nothing ObjectType = "CALC" ServiceName = "SFDocuments.Calc" Set _Component = 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 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 SheetName As Variant) As String ''' Returns the last used cell in a given sheet LastCell = _PropertyGet("LastCell", SheetName) End Property ' SFDocuments.SF_Calc.LastCell REM ----------------------------------------------------------------------------- Property Get LastColumn(Optional ByVal SheetName As Variant) As Long ''' Returns the last used column in a given sheet LastColumn = _PropertyGet("LastColumn", SheetName) End Property ' SFDocuments.SF_Calc.LastColumn REM ----------------------------------------------------------------------------- Property Get LastRow(Optional ByVal SheetName As Variant) As Long ''' Returns the last used column in a given sheet LastRow = _PropertyGet("LastRow", SheetName) 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 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 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 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 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 Sub ClearAll(Optional ByVal Range As Variant) As String ''' Clear entirely the given range ''' Args: ''' Range : the cell or the range as a string that should be cleared ''' Examples: ''' oDoc.ClearAll("SheetX") ' Clears the used area of the sheet Dim lClear As Long ' The elements to clear Dim oRange As Object ' Alias of Range Const cstThisSub = "SFDocuments.Calc.ClearAll" Const cstSubArgs = "Range" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch 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: With com.sun.star.sheet.CellFlags lClear = 0 _ + .VALUE _ + .DATETIME _ + .STRING _ + .ANNOTATION _ + .FORMULA _ + .HARDATTR _ + .STYLES _ + .OBJECTS _ + .EDITATTR _ + .FORMATTED Set oRange = _ParseAddress(Range) oRange.XCellRange.clearContents(lClear) End With Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Sub Catch: GoTo Finally End Sub ' SF_Documents.SF_Calc.ClearAll REM ----------------------------------------------------------------------------- Public Sub ClearFormats(Optional ByVal Range As Variant) As String ''' Clear all the formatting elements of the given range ''' Args: ''' Range : the cell or the range as a string that should be cleared ''' Examples: ''' oDoc.ClearFormats("SheetX:A1:E100") ' Clear the formats of the given range Dim lClear As Long ' The elements to clear Dim oRange As Object ' Alias of Range Const cstThisSub = "SFDocuments.Calc.ClearFormats" Const cstSubArgs = "Range" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch 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: With com.sun.star.sheet.CellFlags lClear = 0 _ + .HARDATTR _ + .STYLES _ + .EDITATTR _ + .FORMATTED Set oRange = _ParseAddress(Range) oRange.XCellRange.clearContents(lClear) End With Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Sub Catch: GoTo Finally End Sub ' SF_Documents.SF_Calc.ClearFormats REM ----------------------------------------------------------------------------- Public Sub ClearValues(Optional ByVal Range As Variant) As String ''' Clear values and formulas in the given range ''' Args: ''' Range : the cell or the range as a string that should be cleared ''' Examples: ''' oDoc.ClearValues("SheetX:*") ' Clears the used area of the sheet Dim lClear As Long ' The elements to clear Dim oRange As Object ' Alias of Range Const cstThisSub = "SFDocuments.Calc.ClearValues" Const cstSubArgs = "Range" If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch 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: With com.sun.star.sheet.CellFlags lClear = 0 _ + .VALUE _ + .DATETIME _ + .STRING _ + .FORMULA Set oRange = _ParseAddress(Range) oRange.XCellRange.clearContents(lClear) End With Finally: ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Sub Catch: GoTo Finally End Sub ' SF_Documents.SF_Calc.ClearValues 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", 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 va 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: 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 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 ' SF_Documents.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 ' SF_Documents.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 ' SF_Documents.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 ' SF_Documents.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 ' SF_Documents.SF_Calc.DSum 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 ' SF_Documents.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 ' SF_Documents.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.openoffice.org/wiki/Documentation/DevGuide/Spreadsheets/Filter_Options#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( _ "Activate" _ , "ClearAll" _ , "ClearFormats" _ , "ClearValues" _ , "CloseDocument" _ , "CopySheet" _ , "CopySheetFromFile" _ , "CopyToCell" _ , "CopyToRange" _ , "DAvg" _ , "DCount" _ , "DMax" _ , "DMin" _ , "DSum" _ , "GetColumnName" _ , "GetFormula" _ , "GetValue" _ , "ImportFromCSVFile" _ , "ImportFromDatabase" _ , "InsertSheet" _ , "MoveRange" _ , "MoveSheet" _ , "Offset" _ , "RemoveSheet" _ , "RenameSheet" _ , "RunCommand" _ , "Save" _ , "SaveAs" _ , "SaveCopyAs" _ , "SetArray" _ , "SetCellStyle" _ , "SetFormula" _ , "SetValue" _ , "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 ' SF_Documents.SF_Calc.Offset 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" _ , "Height" _ , "IsBase" _ , "IsCalc" _ , "IsDraw" _ , "IsImpress" _ , "IsMath" _ , "IsWriter" _ , "Keywords" _ , "LastCell" _ , "LastColumn" _ , "LastRow" _ , "Range" _ , "Readonly" _ , "Sheet" _ , "Sheets" _ , "Subject" _ , "Title" _ , "Width" _ , "XCellRange" _ , "XComponent" _ , "XSpreadsheet" _ ) End Function ' SFDocuments.SF_Calc.Properties 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 ' SF_Documents.SF_Calc.SetArray REM ----------------------------------------------------------------------------- Public Function SetCellStyle(Optional ByVal TargetRange As Variant _ , Optional ByVal Style As Variant _ ) As String ''' Apply the given cell style in the given range ''' The full range is updated and the remainder of the sheet is left untouched ''' If the cell style does not exist, an error is raised ''' Args: ''' TargetRange : the range as a string that should receive a new cell style ''' Style: the style name as a string ''' Returns: ''' A string representing the updated range ''' Examples: ''' oDoc.SetCellStyle("A1:F1", "Heading 2") 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 Const cstStyle = "CellStyles" Const cstThisSub = "SFDocuments.Calc.SetCellStyle" Const cstSubArgs = "TargetRange, Style" 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 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 End If Try: Set oAddress = _ParseAddress(TargetRange) With oAddress .XCellRange.CellStyle = Style sSet = .RangeName End With Finally: SetCellStyle = sSet ScriptForge.SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' SF_Documents.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 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", V_STRING) 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: Set oAddress = _ParseAddress(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 ' SF_Documents.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 of 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 ' SF_Documents.SF_Calc.SetValue 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 maximum 3 columns/rows. The sorting order may vary by column/row ''' 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 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 i As Long 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", V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", V_BOOLEAN) Then GoTo Finally If Not ScriptForge.SF_Utils._Validate(SortColumns, "SortColumns", V_BOOLEAN) Then GoTo Finally End If Set oRangeAddress = _ParseAddress(Range) If Len(DestinationCell) > 0 Then Set oDestRange = _ParseAddress(DestinationCell) Try: ' Initialize the sort descriptor Set oRange = oRangeAddress.XCellRange vSortDescriptor = oRange.createSortDescriptor ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsSortColumns", SortColumns) ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "ContainsHeader", ContainsHeader) ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "BindFormatsToContent", True) If Len(DestinationCell) = 0 Then ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", False) 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 ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", true) ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "OutputPosition", oDestCell) End If ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsUserListEnabled", False) ' Define the sorting keys vSortFields = Array() ReDim vSortFields(0 To UBound(SortKeys)) For i = 0 To UBound(SortKeys) vSortFields(i) = New com.sun.star.table.TableSortField If i > UBound(SortOrder) Then sOrder = "" Else sOrder = SortOrder(i) If Len(sOrder) = 0 Then sOrder = "ASC" With vSortFields(i) .Field = SortKeys(i) - 1 .IsAscending = ( UCase(sOrder) = "ASC" ) .IsCaseSensitive = CaseSensitive End With Next i ' Associate the keys and the descriptor, and sort ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "SortFields", vSortFields) oRange.sort(vSortDescriptor) ' 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 ' SF_Documents.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 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 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 Sub RunCommand(Optional ByVal Command As Variant) [_Super].RunCommand(Command) 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 =========================================================== PRIVATE FUNCTIONS 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 ' SF_Documents.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 ' SF_Documents.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 ' SF_Documents.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 ' SF_Documents.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,..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' ''' 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: lDiv = plColumnNumber Do While lDiv > 0 lMod = (lDiv - 1) Mod 26 sCol = Chr(65 + lMod) + sCol lDiv = Int((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 ' SF_Documents.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 ~ ''' Returns: ''' An object of type _Address ''' Exceptions: ''' CALCADDRESSERROR ' Address could not be parsed to a valid address Dim oAddress As _Address ' Return value 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 With oAddress sSheet = "" : sRange = "" .SheetName = "" : .RangeName = "" .ObjectType = CALCREFERENCE .ServiceName = SERVICEREFERENCE .RawAddress = psAddress Set .XSpreadSheet = Nothing : Set .XCellRange = Nothing ' Split in sheet and range components - Check presence of surrounding single quotes or dot If Left(psAddress, 1) = "'" Then lStart = 1 sSheet = ScriptForge.SF_String.FindRegex(psAddress, "^'[^\[\]*?:\/\\]+'") If lStart = 0 Then GoTo CatchAddress ' Invalid sheet name If Len(psAddress) > Len(sSheet) + 1 Then If Mid(psAddress, Len(sSheet) + 1, 1) = "." then sRange = Mid(psAddress, Len(sSheet) + 2) End If sSheet = Replace(Replace(sSheet, "$", ""), "'", "") ElseIf InStr(psAddress, ".") > 0 Then sSheet = Replace(Split(psAddress, ".")(0), "$", "") sRange = Replace(Split(psAddress, ".")(1), "$", "") Else sSheet = psAddress End If ' 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 = _RangeToString(oRangeAddress) .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 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 i As Long Dim cstThisSub As String Const cstSubArgs = "" _PropertyGet = False cstThisSub = "SFDocuments.SF_Calc.get" & psProperty ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) If Not _IsStillAlive() Then GoTo Finally Select Case psProperty Case "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 "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 "LastCell", "LastColumn", "LastRow" If IsMissing(pvArg) Or IsEmpty(pvArg) Then ' Avoid errors when instance is watched in Basic IDE _PropertyGet = -1 Else If Not _ValidateSheet(pvArg, "SheetName", , True) Then GoTo Finally vLastCell = _LastCell(_Component.getSheets.getByName(pvArg)) If psProperty = "LastRow" Then _PropertyGet = vLastCell(1) ElseIf psProperty = "LastColumn" Then _PropertyGet = vLastCell(0) Else _PropertyGet = GetColumnName(vLastCell(0)) & CStr(vLastCell(1)) End If End If Case "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 "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 "Sheets" _PropertyGet = _Component.getSheets.getElementNames() Case "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 "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 "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 _RangeToString(ByRef poAddress As Object) As String ''' Converts a range address to its A1 notation) With poAddress _RangeToString = _GetColumnName(.StartColumn + 1) & CStr(.StartRow + 1) & ":" _ & _GetColumnName(.EndColumn + 1) & CStr(.EndRow + 1) End With End Function ' SFDocuments.SF_Calc._RangeToString 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 _ ) 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 ''' 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 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 ' 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 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 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 ============================================ END OF SFDOCUMENTS.SF_CALC