| blob | 7bd5e4e8d2517ec7e89104a5143c6e504ce053a7 |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Calc" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
4 REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
5 REM === The SFDocuments library is one of the associated libraries. ===
6 REM === Full documentation is available on https://help.libreoffice.org/ ===
7 REM =======================================================================================================================
9 Option Compatible
10 Option ClassModule
12 Option Explicit
14 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
15 ''' SF_Calc
16 ''' =======
17 '''
18 ''' The SFDocuments library gathers a number of methods and properties making easy
19 ''' managing and manipulating LibreOffice documents
20 '''
21 ''' Some methods are generic for all types of documents: they are combined in the SF_Document module.
22 ''' Specific properties and methods are implemented in the concerned subclass(es) SF_Calc, SF_Base, ...
23 '''
24 ''' To workaround the absence of class inheritance in LibreOffice Basic, some redundancy is necessary
25 ''' Each subclass MUST implement also the generic methods and properties, even if they only call
26 ''' the parent methods and properties.
27 ''' They should also duplicate some generic private members as a subset of their own set of members
28 '''
29 ''' The SF_Calc module is focused on :
30 ''' - management (copy, insert, move, ...) of sheets within a Calc document
31 ''' - exchange of data between Basic data structures and Calc ranges of values
32 ''' - copying and importing massive amounts of data
33 '''
34 ''' The current module is closely related to the "UI" service of the ScriptForge library
35 '''
36 ''' Service invocation examples:
38 ''' Dim ui As Object, oDoc As Object
43 ''' Dim oDoc As Object
44 ''' Set oDoc = CreateScriptService("SFDocuments.Calc", "Untitled 1") ' Default = ActiveWindow
45 ''' ' or Set oDoc = CreateScriptService("SFDocuments.Calc", "Untitled 1") ' Untitled 1 is presumed a Calc document
47 '''
48 ''' Definitions:
49 '''
50 ''' Many methods require a "Sheet" or a "Range" as argument. (NB: a single cell is considered as a special case of a Range)
51 ''' Usually, within a specific Calc instance, sheets and ranges are given as a string: "SheetX" and "D2:F6"
52 ''' Multiple ranges are not supported in this context.
53 ''' Additionally, the .Sheet and .Range methods return a reference that may be used
54 ''' as argument of a method called from another instance of the Calc service
55 ''' Example:
56 ''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\FileA.ods", Hidden := True, ReadOnly := True)
58 ''' oDocB.CopyToRange(oDocA.Range("SheetX.D4:F8"), "D2:F6") ' CopyToRange(source, target)
59 '''
60 ''' Sheet: the sheet name as a string or an object produced by .Sheet()
62 ''' Range: a string designating a set of contiguous cells located in a sheet of the current instance
64 ''' or an object produced by .Range()
65 ''' The sheet name is optional (default = active sheet). Surrounding quotes and $ signs are optional
66 ''' ~.~, ~ The current selection in the active sheet
68 ''' $SheetX.D2:F6, D2:D10 Multiple cells
69 ''' $'SheetX'.A:A or 3:5 All cells in the same column or row up to the last active cell
70 ''' SheetX.* All cells up to the last active cell
71 ''' myRange A range name at spreadsheet level
72 ''' ~.yourRange, SheetX.someRange A range name at sheet level
74 ''' A range within the sheet SheetX in file associated with the myDoc Calc instance
75 '''
77 ''' A FilterFormula may be associated with a FilterScope: "row", "column" or "cell".
78 ''' These arguments determine on which rows/columns/cells of a range the method should be applied
79 ''' Examples:
80 ''' oDoc.ClearAll("A1:J10", FilterFormula := "=(A1<=0)", FilterScope := "CELL") ' Clear all negative values
81 ''' oDoc.ClearAll("SheetX.A1:J10", "=SUM(SheetX.A1:A10)>100", "COLUMN") ' Clear all columns whose sum is greater than 500
82 '''
83 ''' FilterFormula: a Calc formula that returns TRUE or FALSE
84 ''' the formula is expressed in terms of
88 ''' relative and absolute references will be interpreted correctly
89 ''' FilterScope: the way the formula is applied, once by row, by column, or by individual cell
90 '''
91 ''' Detailed user documentation:
92 ''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_calc.html?DbPAR=BASIC
93 '''
94 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
96 REM ================================================================== EXCEPTIONS
107 REM ============================================================= PRIVATE MEMBERS
109 Private [Me] As Object
110 Private [_Super] As Object ' Document superclass, which the current instance is a subclass of
111 Private ObjectType As String ' Must be CALC
112 Private ServiceName As String
114 ' Window component
115 Private _Component As Object ' com.sun.star.lang.XComponent
117 Type _Address
120 RawAddress As String
121 Component As Object ' com.sun.star.lang.XComponent
122 SheetName As String
123 SheetIndex As Integer
124 RangeName As String
125 Height As Long
126 Width As Long
127 XSpreadSheet As Object ' com.sun.star.sheet.XSpreadsheet
128 XCellRange As Object ' com.sun.star.table.XCellRange
129 End Type
131 Private _LastParsedAddress As Object ' _Address type - parsed ranges are cached
133 REM ============================================================ MODULE CONSTANTS
135 Private Const cstSHEET = 1
136 Private Const cstRANGE = 2
143 ' Service name of _Address (used in Python)
148 ' Presence of a special character forces surrounding the sheet name with single quotes in absolute addresses
151 REM ====================================================== CONSTRUCTOR/DESTRUCTOR
153 REM -----------------------------------------------------------------------------
154 Private Sub Class_Initialize()
155 Set [Me] = Nothing
156 Set [_Super] = Nothing
159 Set _Component = Nothing
160 Set _LastParsedAddress = Nothing
161 End Sub ' SFDocuments.SF_Calc Constructor
163 REM -----------------------------------------------------------------------------
164 Private Sub Class_Terminate()
165 Call Class_Initialize()
166 End Sub ' SFDocuments.SF_Calc Destructor
168 REM -----------------------------------------------------------------------------
169 Public Function Dispose() As Variant
170 If Not IsNull([_Super]) Then Set [_Super] = [_Super].Dispose()
171 Call Class_Terminate()
172 Set Dispose = Nothing
173 End Function ' SFDocuments.SF_Calc Explicit Destructor
175 REM ================================================================== PROPERTIES
177 REM -----------------------------------------------------------------------------
178 Property Get CurrentSelection() As Variant
179 ''' Returns as a string the currently selected range or as an array the list of the currently selected ranges
181 End Property ' SFDocuments.SF_Calc.CurrentSelection (get)
183 REM -----------------------------------------------------------------------------
184 Property Let CurrentSelection(Optional ByVal pvSelection As Variant)
185 ''' Set the selection to a single or a multiple range
186 ''' The argument is a string or an array of strings
188 Dim sRange As String ' A single selection
189 Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges
190 Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress
191 Dim i As Long
195 On Local Error GoTo Catch
197 Check:
198 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
199 If Not _IsStillAlive(True) Then GoTo Finally
200 If IsArray(pvSelection) Then
201 If Not ScriptForge.SF_Utils._ValidateArray(pvSelection, "pvSelection", 1, V_STRING, True) Then GoTo Finally
202 Else
203 If Not ScriptForge.SF_Utils._Validate(pvSelection, "pvSelection", V_STRING) Then GoTo Finally
204 End If
205 End If
207 Try:
208 If IsArray(pvSelection) Then
210 vRangeAddresses = Array()
211 ReDim vRangeAddresses(0 To UBound(pvSelection))
212 For i = 0 To UBound(pvSelection)
213 vRangeAddresses(i) = Range(pvSelection(i)).XCellRange.RangeAddress
214 Next i
215 oCellRanges.addRangeAddresses(vRangeAddresses, False)
216 _Component.CurrentController.select(oCellRanges)
217 Else
218 _Component.CurrentController.select(_ParseAddress(pvSelection).XCellRange)
219 End If
221 Finally:
222 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
223 Exit Property
224 Catch:
225 GoTo Finally
226 End Property ' SFDocuments.SF_Calc.CurrentSelection (let)
228 REM -----------------------------------------------------------------------------
229 Property Get FirstCell(Optional ByVal RangeName As Variant) As String
230 ''' Returns the First used cell in a given range or sheet
231 ''' When the argument is a sheet it will always return the "sheet.$A$1" cell
233 End Property ' SFDocuments.SF_Calc.FirstCell
235 REM -----------------------------------------------------------------------------
236 Property Get FirstColumn(Optional ByVal RangeName As Variant) As Long
237 ''' Returns the leftmost column in a given sheet or range
240 End Property ' SFDocuments.SF_Calc.FirstColumn
242 REM -----------------------------------------------------------------------------
243 Property Get FirstRow(Optional ByVal RangeName As Variant) As Long
244 ''' Returns the First used column in a given range
247 End Property ' SFDocuments.SF_Calc.FirstRow
249 REM -----------------------------------------------------------------------------
250 Property Get Height(Optional ByVal RangeName As Variant) As Long
251 ''' Returns the height in # of rows of the given range
253 End Property ' SFDocuments.SF_Calc.Height
255 REM -----------------------------------------------------------------------------
256 Property Get LastCell(Optional ByVal RangeName As Variant) As String
257 ''' Returns the last used cell in a given sheet or range
259 End Property ' SFDocuments.SF_Calc.LastCell
261 REM -----------------------------------------------------------------------------
262 Property Get LastColumn(Optional ByVal RangeName As Variant) As Long
263 ''' Returns the last used column in a given sheet
265 End Property ' SFDocuments.SF_Calc.LastColumn
267 REM -----------------------------------------------------------------------------
268 Property Get LastRow(Optional ByVal RangeName As Variant) As Long
269 ''' Returns the last used column in a given sheet
271 End Property ' SFDocuments.SF_Calc.LastRow
273 REM -----------------------------------------------------------------------------
274 Property Get Range(Optional ByVal RangeName As Variant) As Variant
275 ''' Returns a (internal) range object
277 End Property ' SFDocuments.SF_Calc.Range
279 REM -----------------------------------------------------------------------------
280 Property Get Region(Optional ByVal RangeName As Variant) As String
281 ''' Returns the smallest area as a range string that contains the given range
282 ''' and which is completely surrounded with empty cells
284 End Property ' SFDocuments.SF_Calc.Region
286 REM -----------------------------------------------------------------------------
287 Property Get Sheet(Optional ByVal SheetName As Variant) As Variant
288 ''' Returns a (internal) sheet object
290 End Property ' SFDocuments.SF_Calc.Sheet
292 REM -----------------------------------------------------------------------------
293 Property Get SheetName(Optional ByVal RangeName As Variant) As String
294 ''' Returns the sheet name part of a range
296 End Property ' SFDocuments.SF_Calc.SheetName
298 REM -----------------------------------------------------------------------------
299 Property Get Sheets() As Variant
300 ''' Returns an array listing the existing sheet names
302 End Property ' SFDocuments.SF_Calc.Sheets
304 REM -----------------------------------------------------------------------------
305 Property Get Width(Optional ByVal RangeName As Variant) As Long
306 ''' Returns the width in # of columns of the given range
308 End Property ' SFDocuments.SF_Calc.Width
310 REM -----------------------------------------------------------------------------
311 Property Get XCellRange(Optional ByVal RangeName As Variant) As Variant
312 ''' Returns a UNO object of type com.sun.star.Table.CellRange
314 End Property ' SFDocuments.SF_Calc.XCellRange
316 REM -----------------------------------------------------------------------------
317 Property Get XRectangle(Optional ByVal RangeName As Variant) As Variant
318 ''' Returns a UNO structure of type com.sun.star.awt.Rectangle
319 ''' describing the area in pixels on the screen where the range is located.
320 ''' Useful in the context of running mouse events and widgets like popup menus
322 End Property ' SFDocuments.SF_Calc.XRectangle
324 REM -----------------------------------------------------------------------------
325 Property Get XSheetCellCursor(Optional ByVal RangeName As Variant) As Variant
326 ''' Returns a UNO object of type com.sun.star.sheet.XSheetCellCursor
327 '' After having moved the cursor (gotoNext(), ...) the resulting range can be got
328 ''' back as a string with the cursor.AbsoluteName UNO property.
330 End Property ' SFDocuments.SF_Calc.XSheetCellCursor
332 REM -----------------------------------------------------------------------------
333 Property Get XSpreadsheet(Optional ByVal SheetName As Variant) As Variant
334 ''' Returns a UNO object of type com.sun.star.sheet.XSpreadsheet
336 End Property ' SFDocuments.SF_Calc.XSpreadsheet
338 REM ===================================================================== METHODS
340 REM -----------------------------------------------------------------------------
341 Public Function A1Style(Optional ByVal Row1 As Variant _
342 , Optional ByVal Column1 As Variant _
343 , Optional ByVal Row2 As Variant _
344 , Optional ByVal Column2 As Variant _
345 , Optional ByVal SheetName As Variant _
346 ) As String
347 ''' Returns a range expressed in A1-style as defined by its coordinates
348 ''' If only one pair of coordinates is given, the range will embrace only a single cell
349 ''' Args:
350 ''' Row1 : the row number of the first coordinate
351 ''' Column1 : the column number of the first coordinates
352 ''' Row2 : the row number of the second coordinate
353 ''' Column2 : the column number of the second coordinates
354 ''' SheetName: Default = the current sheet. If present, the sheet must exist.
355 ''' Returns:
356 ''' A range as a string
357 ''' Exceptions:
358 ''' Examples:
359 ''' range = oDoc.A1Style(5, 2, 10, 4, "SheetX") ' "'$SheetX'.$E$2:$J$4"
361 Dim sA1Style As String ' Return value
364 Dim i As Long
367 Const cstSubArgs = "Row1, Column1, [Row2], [Column2], [SheetName]="""""
369 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
370 sA1Style = ""
372 Check:
373 If IsMissing(Row2) Or IsEmpty(Row2) Then Row2 = 0
374 If IsMissing(Column2) Or IsEmpty(Column2) Then Column2 = 0
375 If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = ""
376 vSheetName = SheetName
378 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
379 If Not _IsStillAlive() Then GoTo Finally
380 If Not ScriptForge.SF_Utils._Validate(Row1, "Row1", ScriptForge.V_NUMERIC) Then GoTo Finally
381 If Not ScriptForge.SF_Utils._Validate(Column1, "Column1", ScriptForge.V_NUMERIC) Then GoTo Finally
382 If Not ScriptForge.SF_Utils._Validate(Row2, "Row2", ScriptForge.V_NUMERIC) Then GoTo Finally
383 If Not ScriptForge.SF_Utils._Validate(Column2, "Column2", ScriptForge.V_NUMERIC) Then GoTo Finally
384 If Not _ValidateSheet(vSheetName, "SheetName", , True, True, , , True) Then GoTo Finally
385 End If
387 If Row1 > MAXROWS Then Row1 = MAXROWS
388 If Row2 > MAXROWS Then Row2 = MAXROWS
389 If Column1 > MAXCOLS Then Column1 = MAXCOLS
390 If Column2 > MAXCOLS Then Column2 = MAXCOLS
392 If Row2 = Row1 And Column2 = Column1 Then ' Single cell
393 Row2 = 0
394 Column2 = 0
395 End If
398 lTemp = Row2 : Row2 = Row1 : Row1 = lTemp
399 End If
401 lTemp = Column2 : Column2 = Column1 : Column1 = lTemp
402 End If
404 Try:
405 ' Surround the sheet name with single quotes when required by the presence of special characters
406 If Len(vSheetName) > 0 Then vSheetName = "$" & _QuoteSheetName(vSheetName) & "."
407 ' Define the new range string
408 sA1Style = vSheetName _
410 & Iif(Row2 > 0 And Column2 > 0, ":$" & _GetColumnName(Column2) & "$" & CLng(Row2), "")
412 Finally:
413 A1Style = sA1Style
414 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
415 Exit Function
416 Catch:
417 GoTo Finally
418 End Function ' SFDocuments.SF_Calc.A1Style
420 REM -----------------------------------------------------------------------------
421 Public Function Activate(Optional ByVal SheetName As Variant) As Boolean
422 ''' Make the current document or the given sheet active
423 ''' Args:
424 ''' SheetName: Default = the Calc document as a whole
425 ''' Returns:
426 ''' True if the document or the sheet could be made active
427 ''' Otherwise, there is no change in the actual user interface
428 ''' Examples:
431 Dim bActive As Boolean ' Return value
432 Dim oSheet As Object ' Reference to sheet
436 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
437 bActive = False
439 Check:
440 If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = ""
441 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
442 If Not _IsStillAlive() Then GoTo Finally
444 End If
446 Try:
447 ' Sheet activation, to do only when meaningful, precedes document activation
449 With _Component
450 Set oSheet = .getSheets.getByName(SheetName)
451 Set .CurrentController.ActiveSheet = oSheet
452 End With
453 End If
454 bActive = [_Super].Activate()
456 Finally:
457 Activate = bActive
458 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
459 Exit Function
460 Catch:
461 GoTo Finally
462 End Function ' SFDocuments.SF_Calc.Activate
464 REM -----------------------------------------------------------------------------
465 Public Function Charts(Optional ByVal SheetName As Variant _
466 , Optional ByVal ChartName As Variant _
467 ) As Variant
468 ''' Return either the list of charts present in the given sheet or a chart object
469 ''' Args:
470 ''' SheetName: The name of an existing sheet
471 ''' ChartName: The user-defined name of the targeted chart or the zero-length string
472 ''' Returns:
473 ''' When ChartName = "", return the list of the charts present in the sheet,
474 ''' otherwise, return a new chart service instance
475 ''' Examples:
476 ''' Dim oChart As Object
479 Dim vCharts As Variant ' Return value when array of chart names
480 Dim oChart As Object ' Return value when new chart instance
481 Dim oSheet As Object ' Alias of SheetName as reference
482 Dim oDrawPage As Object ' com.sun.star.drawing.XDrawPage
483 Dim oNextShape As Object ' com.sun.star.drawing.XShape
484 Dim sChartName As String ' Some chart name
485 Dim lCount As Long ' Counter for charts among all drawing objects
486 Dim i As Long
492 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
493 vCharts = Array()
495 Check:
496 If IsMissing(ChartName) Or IsEmpty(ChartName) Then ChartName = ""
497 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
498 If Not _IsStillAlive(True) Then GoTo Finally
500 If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING) Then GoTo Finally
501 End If
503 Try:
504 ' Because the user can change it constantly, the list of valid charts has to be rebuilt at each time
505 ' Explore charts starting from the draw page
506 Set oSheet = _Component.getSheets.getByName(SheetName)
507 Set oDrawPage = oSheet.getDrawPage()
508 vCharts = Array()
509 Set oChart = Nothing
510 lCount = -1
512 Set oNextShape = oDrawPage.getByIndex(i)
513 if oNextShape.supportsService(cstChartShape) Then ' Ignore other shapes
514 sChartName = oNextShape.Name ' User-defined name
516 ' Is chart found ?
518 If ChartName = sChartName Then
519 Set oChart = New SF_Chart
520 With oChart
521 Set .[Me] = oChart
522 Set .[_Parent] = [Me]
523 ._SheetName = SheetName
524 ._DrawIndex = i
525 ._ChartName = ChartName
526 ._PersistentName = oNextShape.PersistName
527 Set ._Shape = oNextShape
528 Set ._Chart = oSheet.getCharts().getByName(._PersistentName)
529 Set ._ChartObject = ._Chart.EmbeddedObject
530 Set ._Diagram = ._ChartObject.Diagram
531 End With
532 Exit For
533 End If
534 End If
535 ' Build stack of chart names
536 lCount = lCount + 1
538 vCharts = Array(sChartName)
539 Else
541 vCharts(lCount) = sChartName
542 End If
543 End If
544 Next i
546 ' Raise error when chart not found
548 If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING, vCharts, True) Then GoTo Finally
549 End If
551 Finally:
552 If Len(ChartName) = 0 Then Charts = vCharts Else Set Charts = oChart
553 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
554 Exit Function
555 Catch:
556 GoTo Finally
557 End Function ' SFDocuments.SF_Calc.Charts
559 REM -----------------------------------------------------------------------------
560 Public Sub ClearAll(Optional ByVal Range As Variant _
561 , Optional FilterFormula As Variant _
562 , Optional FilterScope As Variant _
563 )
564 ''' Clear entirely the given range
565 ''' Args:
566 ''' Range : the cell or the range as a string that should be cleared
567 ''' FilterFormula: a Calc formula to select among the given Range
568 ''' When left empty, all the cells of the range are cleared
569 ''' FilterScope: "CELL" (default value), "ROW" or "COLUMN"
570 ''' When FilterFormula is present, FilterScope is mandatory
571 ''' Examples:
573 ''' oDoc.ClearAll("A1:J20", "=($A1=0)", "ROW") ' Clears all rows when 1st cell is zero
577 End Sub ' SFDocuments.SF_Calc.ClearAll
579 REM -----------------------------------------------------------------------------
580 Public Sub ClearFormats(Optional ByVal Range As Variant _
581 , Optional FilterFormula As Variant _
582 , Optional FilterScope As Variant _
583 )
584 ''' Clear all the formatting elements of the given range
585 ''' Args:
586 ''' Range : the cell or the range as a string that should be cleared
587 ''' FilterFormula: a Calc formula to select among the given Range
588 ''' When left empty, all the cells of the range are cleared
589 ''' FilterScope: "CELL" (default value), "ROW" or "COLUMN"
590 ''' When FilterFormula is present, FilterScope is mandatory
591 ''' Examples:
592 ''' oDoc.ClearFormats("SheetX.*") ' Clears the used area of the sheet
593 ''' oDoc.ClearFormats("A1:J20", "=(MOD(A1;0)=0)", "CELL") ' Clears all even cells
597 End Sub ' SFDocuments.SF_Calc.ClearFormats
599 REM -----------------------------------------------------------------------------
600 Public Sub ClearValues(Optional ByVal Range As Variant _
601 , Optional FilterFormula As Variant _
602 , Optional FilterScope As Variant _
603 )
604 ''' Clear values and formulas in the given range
605 ''' Args:
606 ''' Range : the cell or the range as a string that should be cleared
607 ''' FilterFormula: a Calc formula to select among the given Range
608 ''' When left empty, all the cells of the range are cleared
609 ''' FilterScope: "CELL" (default value), "ROW" or "COLUMN"
610 ''' When FilterFormula is present, FilterScope is mandatory
611 ''' Examples:
612 ''' oDoc.ClearValues("SheetX.*") ' Clears the used area of the sheet
613 ''' oDoc.ClearValues("A2:A20", "=(A2=A1)", "CELL") ' Clears all duplicate cells
617 End Sub ' SFDocuments.SF_Calc.ClearValues
619 REM -----------------------------------------------------------------------------
620 Public Function CompactLeft(Optional ByVal Range As Variant _
621 , Optional ByVal WholeColumn As Variant _
622 , Optional ByVal FilterFormula As Variant _
623 ) As String
624 ''' Delete the columns of a specified range matching a filter expressed as a formula
625 ''' applied on each column.
626 ''' The deleted cells can span whole columns or be limited to the height of the range
627 ''' The execution of the method has no effect on the current selection
628 ''' Args:
629 ''' Range: the range in which cells have to be erased, as a string
630 ''' WholeColumn: when True (default = False), erase whole columns
631 ''' FilterFormula: the formula to be applied on each column.
632 ''' The column is erased when the formula results in True,
633 ''' The formula shall probably involve one or more cells of the first column of the range.
634 ''' By default, a column is erased when all the cells of the column are empty,
635 ''' i.e. suppose the range is "A1:J200" (height = 200) the default value becomes
637 ''' Returns:
638 ''' A string representing the location of the initial range after compaction,
639 ''' or the zero-length string if the whole range has been deleted
640 ''' Examples:
641 ''' newrange = oDoc.CompactLeft("SheetX.G1:L10") ' All empty columns of the range are suppressed
642 ''' newrange = oDoc.CompactLeft("SheetX.G1:L10", WholeColumn := True, FilterFormula := "=(G$7=""X"")")
645 Dim sCompact As String ' Return value
646 Dim oCompact As Object ' Return value as an _Address type
647 Dim lCountDeleted As Long ' Count the deleted columns
648 Dim vCompactRanges As Variant ' Array of ranges to be compacted based on the formula
649 Dim oSourceAddress As Object ' Alias of Range as _Address
650 Dim oPartialRange As Object ' Contiguous columns to be deleted
651 Dim sShiftRange As String ' Contiguous columns to be shifted
652 Dim i As Long
655 Const cstSubArgs = "Range, [WholeColumn=False], [FilterFormula=""""]"
657 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
658 sCompact = ""
660 Check:
661 If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False
662 If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = ""
663 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
664 If Not _IsStillAlive(True) Then GoTo Finally
666 If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally
667 If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally
668 End If
670 Try:
671 Set oSourceAddress = _ParseAddress(Range)
672 lCountDeleted = 0
674 With oSourceAddress
677 If FilterFormula = "" Then FilterFormula = Printf("=(COUNTBLANK(%C1%R1:%C1%R2)-" & .Height & "=0)", Range)
679 ' Identify the ranges to compact based on the given formula
682 ' Iterate through the ranges from bottom to top and shift them up
684 Set oPartialRange = vCompactRanges(i)
685 ShiftLeft(oPartialRange.RangeName, WholeColumn)
686 lCountDeleted = lCountDeleted + oPartialRange.Width
687 Next i
689 ' Compute the final range position
692 ' Push to the right the cells that migrated leftwards irrelevantly
693 If Not WholeColumn Then
694 sShiftRange = Offset(sCompact, 0, .Width - lCountDeleted, , lCountDeleted)
695 ShiftRight(sShiftRange, WholeColumn := False)
696 End If
697 ' Conventionally, if all columns are deleted, the returned range is the zero-length string
698 If .Width = lCountDeleted Then sCompact = ""
699 Else ' Initial range is left unchanged
700 sCompact = .RangeName
701 End If
703 End With
705 Finally:
706 CompactLeft = sCompact
707 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
708 Exit Function
709 Catch:
710 ' When error, return the original range
711 If Not IsNull(oSourceAddress) Then sCompact = oSourceAddress.RangeName
712 GoTo Finally
713 End Function ' SFDocuments.SF_Calc.CompactLeft
715 REM -----------------------------------------------------------------------------
716 Public Function CompactUp(Optional ByVal Range As Variant _
717 , Optional ByVal WholeRow As Variant _
718 , Optional ByVal FilterFormula As Variant _
719 ) As String
720 ''' Delete the rows of a specified range matching a filter expressed as a formula
721 ''' applied on each row.
722 ''' The deleted cells can span whole rows or be limited to the width of the range
723 ''' The execution of the method has no effect on the current selection
724 ''' Args:
725 ''' Range: the range in which cells have to be erased, as a string
726 ''' WholeRow: when True (default = False), erase whole rows
727 ''' FilterFormula: the formula to be applied on each row.
728 ''' The row is erased when the formula results in True,
729 ''' The formula shall probably involve one or more cells of the first row of the range.
730 ''' By default, a row is erased when all the cells of the row are empty,
731 ''' i.e. suppose the range is "A1:J200" (width = 10) the default value becomes
733 ''' Returns:
734 ''' A string representing the location of the initial range after compaction,
735 ''' or the zero-length string if the whole range has been deleted
736 ''' Examples:
737 ''' newrange = oDoc.CompactUp("SheetX.G1:L10") ' All empty rows of the range are suppressed
738 ''' newrange = oDoc.CompactUp("SheetX.G1:L10", WholeRow := True, FilterFormula := "=(G1=""X"")")
741 Dim sCompact As String ' Return value
742 Dim lCountDeleted As Long ' Count the deleted rows
743 Dim vCompactRanges As Variant ' Array of ranges to be compacted based on the formula
744 Dim oSourceAddress As Object ' Alias of Range as _Address
745 Dim oPartialRange As Object ' Contiguous rows to be deleted
746 Dim sShiftRange As String ' Contiguous rows to be shifted
747 Dim i As Long
750 Const cstSubArgs = "Range, [WholeRow=False], [FilterFormula=""""]"
752 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
753 sCompact = ""
755 Check:
756 If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False
757 If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = ""
758 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
759 If Not _IsStillAlive(True) Then GoTo Finally
761 If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally
762 If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally
763 End If
765 Try:
766 Set oSourceAddress = _ParseAddress(Range)
767 lCountDeleted = 0
769 With oSourceAddress
772 If FilterFormula = "" Then FilterFormula = Printf("=(COUNTBLANK(%C1%R1:%C2%R1)-" & .Width & "=0)", Range)
774 ' Identify the ranges to compact based on the given formula
777 ' Iterate through the ranges from bottom to top and shift them up
779 Set oPartialRange = vCompactRanges(i)
780 ShiftUp(oPartialRange.RangeName, WholeRow)
781 lCountDeleted = lCountDeleted + oPartialRange.Height
782 Next i
784 ' Compute the final range position
787 ' Push downwards the cells that migrated upwards irrelevantly
788 If Not WholeRow Then
789 sShiftRange = Offset(sCompact, .Height - lCountDeleted, 0, lCountDeleted)
790 ShiftDown(sShiftRange, WholeRow := False)
791 End If
792 ' Conventionally, if all rows are deleted, the returned range is the zero-length string
793 If .Height = lCountDeleted Then sCompact = ""
794 Else ' Initial range is left unchanged
795 sCompact = .RangeName
796 End If
798 End With
800 Finally:
801 CompactUp = sCompact
802 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
803 Exit Function
804 Catch:
805 ' When error, return the original range
806 If Not IsNull(oSourceAddress) Then sCompact = oSourceAddress.RangeName
807 GoTo Finally
808 End Function ' SFDocuments.SF_Calc.CompactUp
810 REM -----------------------------------------------------------------------------
811 Public Function CopySheet(Optional ByVal SheetName As Variant _
812 , Optional ByVal NewName As Variant _
813 , Optional ByVal BeforeSheet As Variant _
814 ) As Boolean
815 ''' Copy a specified sheet before an existing sheet or at the end of the list of sheets
816 ''' The sheet to copy may be inside any open Calc document
817 ''' Args:
818 ''' SheetName: The name of the sheet to copy or its reference
819 ''' NewName: Must not exist
820 ''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert
821 ''' Returns:
822 ''' True if the sheet could be copied successfully
823 ''' Exceptions:
824 ''' DUPLICATESHEETERROR A sheet with the given name exists already
825 ''' Examples:
827 ''' ' Copy within the same document
828 ''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True)
829 ''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods")
833 Dim bCopy As Boolean ' Return value
834 Dim oSheets As Object ' com.sun.star.sheet.XSpreadsheets
835 Dim vSheets As Variant ' List of existing sheets
836 Dim lSheetIndex As Long ' Index of a sheet
837 Dim oSheet As Object ' Alias of SheetName as reference
838 Dim lRandom As Long ' Output of random number generator
839 Dim sRandom ' Random sheet name
843 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
844 bCopy = False
846 Check:
847 If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768
848 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
849 If Not _IsStillAlive(True) Then GoTo Finally
853 End If
855 Try:
856 ' Determine the index of the sheet before which to insert the copy
857 Set oSheets = _Component.getSheets
858 vSheets = oSheets.getElementNames()
859 If VarType(BeforeSheet) = V_STRING Then
860 lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet)
861 Else
862 lSheetIndex = BeforeSheet - 1
865 End If
867 ' Copy sheet inside the same document OR import from another document
868 If VarType(SheetName) = V_STRING Then
869 _Component.getSheets.copyByName(SheetName, NewName, lSheetIndex)
870 Else
871 Set oSheet = SheetName
872 With oSheet
873 ' If a sheet with same name as input exists in the target sheet, rename it first with a random name
874 sRandom = ""
875 If ScriptForge.SF_Array.Contains(vSheets, .SheetName) Then
878 oSheets.getByName(.SheetName).setName(sRandom)
879 End If
880 ' Import i.o. Copy
881 oSheets.importSheet(oSheet.Component, .SheetName, lSheetIndex)
882 ' Rename to new sheet name
883 oSheets.getByName(.SheetName).setName(NewName)
884 ' Reset random name
886 End With
887 End If
888 bCopy = True
890 Finally:
891 CopySheet = bCopy
892 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
893 Exit Function
894 Catch:
895 GoTo Finally
896 CatchDuplicate:
897 ScriptForge.SF_Exception.RaiseFatal(DUPLICATESHEETERROR, "NewName", NewName, "Document", [_Super]._FileIdent())
898 GoTo Finally
899 End Function ' SFDocuments.SF_Calc.CopySheet
901 REM -----------------------------------------------------------------------------
902 Public Function CopySheetFromFile(Optional ByVal FileName As Variant _
903 , Optional ByVal SheetName As Variant _
904 , Optional ByVal NewName As Variant _
905 , Optional ByVal BeforeSheet As Variant _
906 ) As Boolean
907 ''' Copy a specified sheet before an existing sheet or at the end of the list of sheets
908 ''' The sheet to copy is located inside any closed Calc document
909 ''' Args:
910 ''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation
911 ''' The file must not be protected with a password
912 ''' SheetName: The name of the sheet to copy
913 ''' NewName: Must not exist
914 ''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert
915 ''' Returns:
916 ''' True if the sheet could be created
917 ''' The created sheet is blank when the input file is not a Calc file
918 ''' The created sheet contains an error message when the input sheet was not found
919 ''' Exceptions:
920 ''' DUPLICATESHEETERROR A sheet with the given name exists already
921 ''' UNKNOWNFILEERROR The input file is unknown
922 ''' Examples:
923 ''' oDoc.CopySheetFromFile("C:\MyFile.ods", "SheetX", "SheetY", 3)
925 Dim bCopy As Boolean ' Return value
926 Dim oSheet As Object ' com.sun.star.sheet.XSpreadsheet
927 Dim sFileName As String ' URL alias of FileName
928 Dim FSO As Object ' SF_FileSystem
930 Const cstSubArgs = "FileName, SheetName, NewName, [BeforeSheet=""""]"
932 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
933 bCopy = False
935 Check:
936 If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768
937 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
938 If Not _IsStillAlive(True) Then GoTo Finally
940 If Not ScriptForge.SF_Utils._Validate(SheetName, "SheetName", V_STRING) Then GoTo Finally
943 End If
945 Try:
946 Set FSO = ScriptForge.SF_FileSystem
947 ' Does the input file exist ?
948 If Not FSO.FileExists(FileName) Then GoTo CatchNotExists
949 sFileName = FSO._ConvertToUrl(FileName)
951 ' Insert a blank new sheet and import sheet from file via link setting and deletion
952 If Not InsertSheet(Newname, BeforeSheet) Then GoTo Finally
953 Set oSheet = _Component.getSheets.getByName(NewName)
954 With oSheet
956 .LinkMode = com.sun.star.sheet.SheetLinkMode.NONE
957 .LinkURL = ""
958 End With
959 bCopy = True
961 Finally:
962 CopySheetFromFile = bCopy
963 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
964 Exit Function
965 Catch:
966 GoTo Finally
967 CatchNotExists:
969 GoTo Finally
970 End Function ' SFDocuments.SF_Calc.CopySheetFromFile
972 REM -----------------------------------------------------------------------------
973 Public Function CopyToCell(Optional ByVal SourceRange As Variant _
974 , Optional ByVal DestinationCell As Variant _
975 ) As String
976 ''' Copy a specified source range to a destination range or cell
977 ''' The source range may belong to another open document
978 ''' The method imitates the behaviour of a Copy/Paste from a range to a single cell
979 ''' Args:
980 ''' SourceRange: the source range as a string if it belongs to the same document
981 ''' or as a reference if it belongs to another open Calc document
982 ''' DestinationCell: the destination of the copied range of cells, as a string
983 ''' If given as a range of cells, the destination will be reduced to its top-left cell
984 ''' Returns:
985 ''' A string representing the modified range of cells
986 ''' The modified area depends only on the size of the source area
987 ''' Examples:
989 ''' ' Copy within the same document
990 ''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True)
991 ''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods")
992 ''' oDocB.CopyToCell(oDocA.Range("SheetX.A1:F10"), "SheetY.C5")
995 Dim sCopy As String ' Return value
996 Dim oSource As Object ' Alias of SourceRange to avoid "Object variable not set" run-time error
997 Dim oSourceAddress As Object ' com.sun.star.table.CellRangeAddress
998 Dim oDestRange As Object ' Destination as a range
999 Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress
1000 Dim oDestCell As Object ' com.sun.star.table.CellAddress
1001 Dim oSelect As Object ' Current selection in source
1002 Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable
1007 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1008 sCopy = ""
1010 Check:
1011 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1012 If Not _IsStillAlive(True) Then GoTo Finally
1013 If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", Array(V_STRING, ScriptForge.V_OBJECT), , , CALCREFERENCE) Then GoTo Finally
1014 If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally
1015 End If
1017 Try:
1018 If VarType(SourceRange) = V_STRING Then ' Same document - Use UNO copyRange method
1019 Set oSourceAddress = _ParseAddress(SourceRange).XCellRange.RangeAddress
1020 Set oDestRange = _ParseAddress(DestinationCell)
1021 Set oDestAddress = oDestRange.XCellRange.RangeAddress
1022 Set oDestCell = New com.sun.star.table.CellAddress
1023 With oDestAddress
1024 oDestCell.Sheet = .Sheet
1025 oDestCell.Column = .StartColumn
1026 oDestCell.Row = .StartRow
1027 End With
1028 oDestRange.XSpreadsheet.copyRange(oDestCell, oSourceAddress)
1029 Else ' Use clipboard to copy - current selection in Source should be preserved
1030 Set oSource = SourceRange
1031 With oSource
1032 ' Keep current selection in source document
1033 Set oSelect = .Component.CurrentController.getSelection()
1034 ' Select, copy the source range and paste in the top-left cell of the destination
1035 .Component.CurrentController.select(.XCellRange)
1036 Set oClipboard = .Component.CurrentController.getTransferable()
1038 _Component.CurrentController.insertTransferable(oClipBoard)
1039 ' Restore previous selection in Source
1040 _RestoreSelections(.Component, oSelect)
1041 Set oSourceAddress = .XCellRange.RangeAddress
1042 End With
1043 End If
1045 With oSourceAddress
1046 sCopy = _Offset(DestinationCell, 0, 0, .EndRow - .StartRow + 1, .EndColumn - .StartColumn + 1).RangeName
1047 End With
1049 Finally:
1050 CopyToCell = sCopy
1051 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1052 Exit Function
1053 Catch:
1054 GoTo Finally
1055 End Function ' SFDocuments.SF_Calc.CopyToCell
1057 REM -----------------------------------------------------------------------------
1058 Public Function CopyToRange(Optional ByVal SourceRange As Variant _
1059 , Optional ByVal DestinationRange As Variant _
1060 ) As String
1061 ''' Copy downwards and/or rightwards a specified source range to a destination range
1062 ''' The source range may belong to another open document
1063 ''' The method imitates the behaviour of a Copy/Paste from a range to a larger range
1064 ''' If the height (resp. width) of the destination area is > 1 row (resp. column)
1065 ''' then the height (resp. width) of the source must be <= the height (resp. width)
1066 ''' of the destination. Otherwise nothing happens
1068 ''' is expanded downwards (resp. rightwards) up to the height (resp. width)
1069 ''' of the source range
1070 ''' Args:
1071 ''' SourceRange: the source range as a string if it belongs to the same document
1072 ''' or as a reference if it belongs to another open Calc document
1073 ''' DestinationRange: the destination of the copied range of cells, as a string
1074 ''' Returns:
1075 ''' A string representing the modified range of cells
1076 ''' Examples:
1078 ''' ' Copy within the same document
1080 ''' Dim oDocA As Object : Set oDocA = ui.OpenDocument("C:\Temp\FileA.ods", Hidden := True, ReadOnly := True)
1081 ''' Dim oDocB As Object : Set oDocB = ui.OpenDocument("C:\Temp\FileB.ods")
1082 ''' oDocB.CopyToRange(oDocA.Range("SheetX.A1:F10"), "SheetY.C5:J5")
1085 Dim sCopy As String ' Return value
1086 Dim oSource As Object ' Alias of SourceRange to avoid "Object variable not set" run-time error
1087 Dim oDestRange As Object ' Destination as a range
1088 Dim oDestCell As Object ' com.sun.star.table.CellAddress
1089 Dim oSelect As Object ' Current selection in source
1090 Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable
1091 Dim bSameDocument As Boolean ' True when source in same document as destination
1092 Dim lHeight As Long ' Height of destination
1093 Dim lWidth As Long ' Width of destination
1098 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1099 sCopy = ""
1101 Check:
1102 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1103 If Not _IsStillAlive(True) Then GoTo Finally
1104 If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", Array(V_STRING, ScriptForge.V_OBJECT), , , CALCREFERENCE) Then GoTo Finally
1105 If Not ScriptForge.SF_Utils._Validate(DestinationRange, "DestinationRange", V_STRING) Then GoTo Finally
1106 End If
1108 Try:
1109 ' Copy done via clipboard
1112 bSameDocument = ( VarType(SourceRange) = V_STRING )
1113 If bSameDocument Then Set oSource = _ParseAddress(SourceRange) Else Set oSource = SourceRange
1114 Set oDestRange = _ParseAddress(DestinationRange)
1115 With oDestRange
1116 lHeight = .Height
1117 lWidth = .Width
1118 If lHeight = 1 Then
1119 lHeight = oSource.Height ' Future height
1120 ElseIf lHeight < oSource.Height Then
1121 GoTo Finally
1122 End If
1123 If lWidth = 1 Then
1124 lWidth = oSource.Width ' Future width
1125 ElseIf lWidth < oSource.Width Then
1126 GoTo Finally
1127 End If
1128 End With
1130 With oSource
1131 ' Store actual selection in source
1132 Set oSelect = .Component.CurrentController.getSelection()
1133 ' Select, copy the source range and paste in the destination
1134 .Component.CurrentController.select(.XCellRange)
1135 Set oClipboard = .Component.CurrentController.getTransferable()
1136 _Component.CurrentController.select(oDestRange.XCellRange)
1137 _Component.CurrentController.insertTransferable(oClipBoard)
1138 ' Restore selection in source
1139 _RestoreSelections(.Component, oSelect)
1140 End With
1144 Finally:
1145 CopyToRange = sCopy
1146 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1147 Exit Function
1148 Catch:
1149 GoTo Finally
1150 End Function ' SFDocuments.SF_Calc.CopyToRange
1152 REM -----------------------------------------------------------------------------
1153 Public Function CreateChart(Optional ByVal ChartName As Variant _
1154 , Optional ByVal SheetName As Variant _
1155 , Optional ByVal Range As Variant _
1156 , Optional ColumnHeader As Variant _
1157 , Optional RowHeader As Variant _
1158 ) As Variant
1159 ''' Return a new chart instance initialized with default values
1160 ''' Args:
1161 ''' ChartName: The user-defined name of the new chart
1162 ''' SheetName: The name of an existing sheet
1163 ''' Range: the cell or the range as a string that should be drawn
1164 ''' ColumnHeader: when True, the topmost row of the range will be used to set labels for the category axis or the legend.
1165 ''' Default = False
1166 ''' RowHeader: when True, the leftmost column of the range will be used to set labels for the category axis or the legend.
1167 ''' Default = False
1168 ''' Returns:
1169 ''' A new chart service instance
1170 ''' Exceptions:
1171 ''' DUPLICATECHARTERROR A chart with the same name exists already in the given sheet
1172 ''' Examples:
1173 ''' Dim oChart As Object
1174 ''' Set oChart = oDoc.CreateChart("myChart", "SheetX", "A1:C8", ColumnHeader := True)
1176 Dim oChart As Object ' Return value
1177 Dim vCharts As Variant ' List of pre-existing charts
1178 Dim oSheet As Object ' Alias of SheetName as reference
1179 Dim oRange As Object ' Alias of Range
1180 Dim oRectangle as new com.sun.star.awt.Rectangle ' Simple shape
1183 Const cstSubArgs = "ChartName, SheetName, Range, [ColumnHeader=False], [RowHeader=False]"
1185 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1186 Set oChart = Nothing
1188 Check:
1189 If IsMissing(RowHeader) Or IsEmpty(RowHeader) Then Rowheader = False
1190 If IsMissing(ColumnHeader) Or IsEmpty(ColumnHeader) Then ColumnHeader = False
1191 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1192 If Not _IsStillAlive(True) Then GoTo Finally
1193 If Not ScriptForge.SF_Utils._Validate(ChartName, "ChartName", V_STRING) Then GoTo Finally
1196 If Not ScriptForge.SF_Utils._Validate(ColumnHeader, "ColumnHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally
1197 If Not ScriptForge.SF_Utils._Validate(RowHeader, "RowHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally
1198 End If
1200 vCharts = Charts(SheetName)
1201 If ScriptForge.SF_Array.Contains(vCharts, ChartName, CaseSensitive := True) Then GoTo CatchDuplicate
1203 Try:
1204 ' The rectangular shape receives arbitrary values. User can Resize() it later
1205 With oRectangle
1208 End With
1209 ' Initialize sheet and range
1210 Set oSheet = _Component.getSheets.getByName(SheetName)
1211 Set oRange = _ParseAddress(Range)
1212 ' Create the chart and get ihe corresponding chart instance
1213 oSheet.getCharts.addNewByName(ChartName, oRectangle, Array(oRange.XCellRange.RangeAddress), ColumnHeader, RowHeader)
1214 Set oChart = Charts(SheetName, ChartName)
1215 oChart._Shape.Name = ChartName ' Both user-defined and internal names match ChartName
1216 oChart._Diagram.Wall.FillColor = RGB(255, 255, 255) ' Align on background color set by the user interface by default
1218 Finally:
1219 Set CreateChart = oChart
1220 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1221 Exit Function
1222 Catch:
1223 GoTo Finally
1224 CatchDuplicate:
1225 ScriptForge.SF_Exception.RaiseFatal(DUPLICATECHARTERROR, "ChartName", ChartName, "SheetName", SheetName, "Document", [_Super]._FileIdent())
1226 GoTo Finally
1227 End Function ' SFDocuments.SF_Calc.CreateChart
1229 REM -----------------------------------------------------------------------------
1230 Public Function CreatePivotTable(Optional ByVal PivotTableName As Variant _
1231 , Optional ByVal SourceRange As Variant _
1232 , Optional ByVal TargetCell As Variant _
1233 , Optional ByRef DataFields As Variant _
1234 , Optional ByRef RowFields As Variant _
1235 , Optional ByRef ColumnFields As Variant _
1236 , Optional ByVal FilterButton As Variant _
1237 , Optional ByVal RowTotals As Variant _
1238 , Optional ByVal ColumnTotals As Variant _
1239 ) As String
1240 ''' Create a new pivot table with the properties defined by the arguments.
1241 ''' If a pivot table with the same name exists already in the targeted sheet, it will be erased without warning.
1242 ''' Args:
1243 ''' PivotTableName: The user-defined name of the new pivottable
1244 ''' SourceRange: The range as a string containing the raw data.
1245 ''' The first row of the range is presumed to contain the field names of the new pivot table
1246 ''' TargetCell: the top left cell or the range as a string where to locate the pivot table.
1247 ''' Only the top left cell of the range will be considered.
1248 ''' DataFields: A single string or an array of field name + function to apply, formatted like:
1250 ''' The allowed functions are: Sum, Count, Average, Max, Min, Product, CountNums, StDev, StDevP, Var, VarP and Median.
1251 ''' The default function is: When the values are all numerical, Sum is used, otherwise Count
1252 ''' RowFields: A single string or an array of the field names heading the pivot table rows
1253 ''' ColumnFields: A single string or an array of the field names heading the pivot table columns
1254 ''' FilterButton: When True (default), display a "Filter" button above the pivot table
1255 ''' RowTotals: When True (default), display a separate column for row totals
1256 ''' ColumnTotals: When True (default), display a separate row for column totals
1257 ''' Returns:
1258 ''' Return the range where the new pivot table is deployed.
1259 ''' Examples:
1260 ''' Dim vData As Variant, oDoc As Object, sTable As String, sPivot As String
1261 ''' vData = Array(Array("Item", "State", "Team", "2002", "2003", "2004"), _
1262 ''' Array("Books", "Michigan", "Jean", 14788, 30222, 23490), _
1263 ''' Array("Candy", "Michigan", "Jean", 26388, 15641, 32849), _
1264 ''' Array("Pens", "Michigan", "Jean", 16569, 32675, 25396), _
1265 ''' Array("Books", "Michigan", "Volker", 21961, 21242, 29009), _
1266 ''' Array("Candy", "Michigan", "Volker", 26142, 22407, 32841))
1269 ''' sPivot = oDoc.CreatePivotTable("PT1", sTable, "H1", Array("2002", "2003;count", "2004;average"), "Item", Array("State", "Team"), False)
1271 Dim sPivotTable As String ' Return value
1272 Dim vData As Variant ' Alias of DataFields
1273 Dim vRows As Variant ' Alias of RowFields
1274 Dim vColumns As Variant ' Alias of ColumnFields
1275 Dim oSourceAddress As Object ' Source as an _Address
1276 Dim oTargetAddress As Object ' Target as an _Address
1277 Dim vHeaders As Variant ' Array of header fields in the source range
1278 Dim oPivotTables As Object ' com.sun.star.sheet.XDataPilotTables
1279 Dim oDescriptor As Object ' com.sun.star.sheet.DataPilotDescriptor
1280 Dim oFields As Object ' ScDataPilotFieldsObj - Collection of fields
1281 Dim oField As Object ' ScDataPilotFieldsObj - A single field
1282 Dim sField As String ' A single field name
1283 Dim sData As String ' A single data field name + function
1284 Dim vDataField As Variant ' A single vData element, split on semicolon
1285 Dim sFunction As String ' Function to apply on a data field (string)
1286 Dim iFunction As Integer ' Equivalent of sFunction as com.sun.star.sheet.GeneralFunction2 constant
1287 Dim oOutputRange As Object ' com.sun.star.table.CellRangeAddress
1288 Dim i As Integer
1291 Const cstSubArgs = "PivotTableName, SourceRange, TargetCell, DataFields, [RowFields], [ColumnFields]" _
1294 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1295 sPivotTable = ""
1297 Check:
1298 If IsMissing(RowFields) Or IsEmpty(RowFields) Then RowFields = Array()
1299 If IsMissing(ColumnFields) Or IsEmpty(ColumnFields) Then ColumnFields = Array()
1300 If IsMissing(FilterButton) Or IsEmpty(FilterButton) Then FilterButton = True
1301 If IsMissing(RowTotals) Or IsEmpty(RowTotals) Then RowTotals = True
1302 If IsMissing(ColumnTotals) Or IsEmpty(ColumnTotals) Then ColumnTotals = True
1303 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1304 If Not _IsStillAlive(True) Then GoTo Finally
1305 If Not ScriptForge.SF_Utils._Validate(PivotTableName, "PivotTableName", V_STRING) Then GoTo Finally
1306 If Not ScriptForge.SF_Utils._Validate(SourceRange, "SourceRange", V_STRING) Then GoTo Finally
1307 If Not ScriptForge.SF_Utils._Validate(TargetCell, "TargetCell", V_STRING) Then GoTo Finally
1308 If IsArray(DataFields) Then
1309 If Not ScriptForge.SF_Utils._ValidateArray(DataFields, "DataFields", 1, V_STRING, True) Then GoTo Finally
1310 Else
1311 If Not ScriptForge.SF_Utils._Validate(DataFields, "DataFields", V_STRING) Then GoTo Finally
1312 End If
1313 If IsArray(RowFields) Then
1314 If Not ScriptForge.SF_Utils._ValidateArray(RowFields, "RowFields", 1, V_STRING, True) Then GoTo Finally
1315 Else
1316 If Not ScriptForge.SF_Utils._Validate(RowFields, "RowFields", V_STRING) Then GoTo Finally
1317 End If
1318 If IsArray(ColumnFields) Then
1319 If Not ScriptForge.SF_Utils._ValidateArray(ColumnFields, "ColumnFields", 1, V_STRING, True) Then GoTo Finally
1320 Else
1321 If Not ScriptForge.SF_Utils._Validate(ColumnFields, "ColumnFields", V_STRING) Then GoTo Finally
1322 End If
1323 If Not ScriptForge.SF_Utils._Validate(FilterButton, "FilterButton", ScriptForge.V_BOOLEAN) Then GoTo Finally
1324 If Not ScriptForge.SF_Utils._Validate(RowTotals, "RowTotals", ScriptForge.V_BOOLEAN) Then GoTo Finally
1325 If Not ScriptForge.SF_Utils._Validate(ColumnTotals, "ColumnTotals", ScriptForge.V_BOOLEAN) Then GoTo Finally
1326 End If
1327 ' Next statements must be outside previous If-block to force their execution even in case of internal call
1328 If IsArray(DataFields) Then vData = DataFields Else vData = Array(DataFields)
1329 If IsArray(RowFields) Then vRows = RowFields Else vRows = Array(RowFields)
1330 If IsArray(ColumnFields) Then vColumns = ColumnFields Else vColumns = Array(ColumnFields)
1332 Try:
1334 Set oSourceAddress = _ParseAddress(SourceRange)
1335 vHeaders = GetValue(Offset(SourceRange, 0, 0, 1)) ' Content of the first row of the source
1337 Set oPivotTables = oTargetAddress.XSpreadsheet.getDataPilotTables()
1339 ' Initialize new pivot table
1340 Set oDescriptor = oPivotTables.createDataPilotDescriptor()
1341 oDescriptor.setSourceRange(oSourceAddress.XCellRange.RangeAddress)
1342 Set oFields = oDescriptor.getDataPilotFields()
1344 ' Set row fields
1345 For i = 0 To UBound(vRows)
1346 sField = vRows(i)
1348 If Not ScriptForge.SF_Utils._Validate(sField, "RowFields", V_STRING, vHeaders, True) Then GoTo Finally
1349 Set oField = oFields.getByName(sField)
1350 oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.ROW
1351 End If
1352 Next i
1354 ' Set column fields
1355 For i = 0 To UBound(vColumns)
1356 sField = vColumns(i)
1358 If Not ScriptForge.SF_Utils._Validate(sField, "ColumnFields", V_STRING, vHeaders, True) Then GoTo Finally
1359 Set oField = oFields.getByName(sField)
1360 oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.COLUMN
1361 End If
1362 Next i
1364 ' Set data fields
1365 For i = 0 To UBound(vData)
1366 sData = vData(i)
1367 ' Minimal parsing
1370 sField = vDataField(0)
1372 ' Define field properties
1374 If Not ScriptForge.SF_Utils._Validate(sField, "DataFields", V_STRING, vHeaders, True) Then GoTo Finally
1375 Set oField = oFields.getByName(sField)
1376 oField.Orientation = com.sun.star.sheet.DataPilotFieldOrientation.DATA
1377 ' Associate the correct function
1378 With com.sun.star.sheet.GeneralFunction2
1379 Select Case UCase(sFunction)
1380 Case "" : iFunction = .AUTO
1393 Case Else
1395 , Array("Sum", "Count", "Average", "Max", "Min", "Product", "CountNums" _
1396 , "StDev", "StDevP", "Var", "VarP", "Median") _
1397 ) Then GoTo Finally
1398 End Select
1399 End With
1400 oField.Function2 = iFunction
1401 End If
1402 Next i
1404 ' Remove any pivot table with same name
1405 If oPivotTables.hasByName(PivotTableName) Then oPivotTables.removeByName(PivotTableName)
1407 ' Finalize the new pivot table
1408 oDescriptor.ShowFilterButton = FilterButton
1409 oDescriptor.RowGrand = RowTotals
1410 oDescriptor.ColumnGrand = ColumnTotals
1411 oPivotTables.insertNewByName(PivotTableName, oTargetAddress.XCellRange.getCellByPosition(0, 0).CellAddress, oDescriptor)
1413 ' Determine the range of the new pivot table
1414 Set oOutputRange = oPivotTables.getByName(PivotTableName).OutputRange
1415 With oOutputRange
1416 sPivotTable = _Component.getSheets().getCellRangeByPosition(.StartColumn, .StartRow, .EndColumn, .EndRow, .Sheet).AbsoluteName
1417 End With
1419 Finally:
1420 CreatePivotTable = sPivotTable
1421 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1422 Exit Function
1423 Catch:
1424 GoTo Finally
1425 End Function ' SFDocuments.SF_Calc.CreatePivotTable
1427 REM -----------------------------------------------------------------------------
1428 Public Function DAvg(Optional ByVal Range As Variant) As Double
1429 ''' Get the average of the numeric values stored in the given range
1430 ''' Args:
1431 ''' Range : the range as a string where to get the values from
1432 ''' Returns:
1433 ''' The average of the numeric values as a double
1434 ''' Examples:
1437 Try:
1440 Finally:
1441 Exit Function
1442 End Function ' SFDocuments.SF_Calc.DAvg
1444 REM -----------------------------------------------------------------------------
1445 Public Function DCount(Optional ByVal Range As Variant) As Long
1446 ''' Get the number of numeric values stored in the given range
1447 ''' Args:
1448 ''' Range : the range as a string where to get the values from
1449 ''' Returns:
1450 ''' The number of numeric values as a Long
1451 ''' Examples:
1454 Try:
1457 Finally:
1458 Exit Function
1459 End Function ' SFDocuments.SF_Calc.DCount
1461 REM -----------------------------------------------------------------------------
1462 Public Function DMax(Optional ByVal Range As Variant) As Double
1463 ''' Get the greatest of the numeric values stored in the given range
1464 ''' Args:
1465 ''' Range : the range as a string where to get the values from
1466 ''' Returns:
1467 ''' The greatest of the numeric values as a double
1468 ''' Examples:
1471 Try:
1474 Finally:
1475 Exit Function
1476 End Function ' SFDocuments.SF_Calc.DMax
1478 REM -----------------------------------------------------------------------------
1479 Public Function DMin(Optional ByVal Range As Variant) As Double
1480 ''' Get the smallest of the numeric values stored in the given range
1481 ''' Args:
1482 ''' Range : the range as a string where to get the values from
1483 ''' Returns:
1484 ''' The smallest of the numeric values as a double
1485 ''' Examples:
1488 Try:
1491 Finally:
1492 Exit Function
1493 End Function ' SFDocuments.SF_Calc.DMin
1495 REM -----------------------------------------------------------------------------
1496 Public Function DSum(Optional ByVal Range As Variant) As Double
1497 ''' Get sum of the numeric values stored in the given range
1498 ''' Args:
1499 ''' Range : the range as a string where to get the values from
1500 ''' Returns:
1501 ''' The sum of the numeric values as a double
1502 ''' Examples:
1505 Try:
1508 Finally:
1509 Exit Function
1510 End Function ' SFDocuments.SF_Calc.DSum
1512 REM -----------------------------------------------------------------------------
1513 Public Function ExportRangeToFile(Optional ByVal Range As Variant _
1514 , Optional ByVal FileName As Variant _
1515 , Optional ByVal ImageType As Variant _
1516 , Optional ByVal Overwrite As Variant _
1517 ) As Boolean
1518 ''' Store the given range as an image to the given file location
1519 ''' Actual selections are not impacted
1520 ''' Inspired by https://stackoverflow.com/questions/30509532/how-to-export-cell-range-to-pdf-file
1521 ''' Args:
1522 ''' Range: sheet name or cell range to be exported, as a string
1523 ''' FileName: Identifies the file where to save. It must follow the SF_FileSystem.FileNaming notation
1524 ''' ImageType: the name of the targeted media type
1525 ''' Allowed values: jpeg, pdf (default) and png
1526 ''' Overwrite: True if the destination file may be overwritten (default = False)
1527 ''' Returns:
1528 ''' False if the document could not be saved
1529 ''' Exceptions:
1530 ''' RANGEEXPORTERROR The destination has its readonly attribute set or overwriting rejected
1531 ''' Examples:
1532 ''' oDoc.ExportRangeToFile('SheetX.B2:J15", "C:\Me\Range2.png", ImageType := "png", Overwrite := True)
1534 Dim bSaved As Boolean ' return value
1535 Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess
1536 Dim sFile As String ' Alias of FileName
1537 Dim vStoreArguments As Variant ' Array of com.sun.star.beans.PropertyValue
1538 Dim vFilterData As Variant ' Array of com.sun.star.beans.PropertyValue
1539 Dim FSO As Object ' SF_FileSystem
1540 Dim vImageTypes As Variant ' Array of permitted image types
1541 Dim vFilters As Variant ' Array of corresponding filters in the same order as vImageTypes
1542 Dim sFilter As String ' The filter to apply
1543 Dim oSelect As Object ' Currently selected range(s)
1544 Dim oAddress As Object ' Alias of Range
1550 Const cstSubArgs = "Range, FileName, [ImageType=""pdf""|""jpeg""|""png""], [Overwrite=False]"
1552 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo CatchError
1553 bSaved = False
1555 Check:
1557 If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False
1560 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1561 If Not _IsStillAlive() Then GoTo Finally
1564 If Not ScriptForge.SF_Utils._Validate(ImageType, "ImageType", V_STRING, vImageTypes) Then GoTo Finally
1565 If Not ScriptForge.SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally
1566 End If
1568 ' Check destination file overwriting
1570 sFile = FSO._ConvertToUrl(FileName)
1571 If FSO.FileExists(FileName) Then
1572 If Overwrite = False Then GoTo CatchError
1574 If oSfa.isReadonly(sFile) Then GoTo CatchError
1575 End If
1577 Try:
1578 ' Setup arguments
1580 sFilter = vFilters(ScriptForge.SF_Array.IndexOf(vImageTypes, ImageType, CaseSensitive := False))
1581 Set oAddress = _ParseAddress(Range)
1583 ' The filter arguments differ between
1587 vFilterData = Array(ScriptForge.SF_Utils._MakePropertyValue("Selection", oAddress.XCellRange) )
1588 vStoreArguments = Array( _
1591 )
1592 Else ' png, jpeg
1593 ' Save the current selection(s)
1594 Set oSelect = _Component.CurrentController.getSelection()
1595 _Component.CurrentController.select(oAddress.XCellRange)
1596 vStoreArguments = Array( _
1599 )
1600 End If
1602 ' Apply the filter and export
1603 _Component.storeToUrl(sFile, vStoreArguments)
1606 bSaved = True
1608 Finally:
1609 ExportRangeToFile = bSaved
1610 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1611 Exit Function
1612 Catch:
1613 GoTo Finally
1614 CatchError:
1615 ScriptForge.SF_Exception.RaiseFatal(RANGEEXPORTERROR, "FileName", FileName, "Overwrite", Overwrite)
1616 GoTo Finally
1617 End Function ' SFDocuments.SF_Chart.ExportRangeToFile
1619 REM -----------------------------------------------------------------------------
1620 Public Function Forms(Optional ByVal SheetName As Variant _
1621 , Optional ByVal Form As Variant _
1622 ) As Variant
1623 ''' Return either
1624 ''' - the list of the Forms contained in the given sheet
1625 ''' - a SFDocuments.Form object based on its name or its index
1626 ''' Args:
1627 ''' SheetName: the name of the sheet containing the requested form or forms
1628 ''' Form: a form stored in the document given by its name or its index
1629 ''' When absent, the list of available forms is returned
1631 ''' Exceptions:
1632 ''' CALCFORMNOTFOUNDERROR Form not found
1633 ''' Returns:
1634 ''' A zero-based array of strings if Form is absent
1635 ''' An instance of the SF_Form class if Form exists
1636 ''' Example:
1637 ''' Dim myForm As Object, myList As Variant
1641 Dim oForm As Object ' The new Form class instance
1642 Dim oMainForm As Object ' com.sun.star.comp.sdb.Content
1643 Dim oXForm As Object ' com.sun.star.form.XForm or com.sun.star.comp.forms.ODatabaseForm
1644 Dim vFormNames As Variant ' Array of form names
1645 Dim oForms As Object ' Forms collection
1651 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1653 Check:
1654 If IsMissing(Form) Or IsEmpty(Form) Then Form = ""
1655 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1656 If Not _IsStillAlive() Then GoTo Finally
1658 If Not ScriptForge.SF_Utils._Validate(Form, "Form", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally
1659 End If
1661 Try:
1662 ' Start from the Calc sheet and go down to forms
1663 Set oForms = _Component.getSheets.getByName(SheetName).DrawPage.Forms
1664 vFormNames = oForms.getElementNames()
1667 Forms = vFormNames
1668 Else
1669 If VarType(Form) = V_STRING Then ' Find the form by name
1670 If Not ScriptForge.SF_Utils._Validate(Form, "Form", V_STRING, vFormNames, True) Then GoTo Finally
1671 Set oXForm = oForms.getByName(Form)
1672 Else ' Find the form by index
1674 Set oXForm = oForms.getByIndex(Form)
1675 End If
1676 ' Create the new Form class instance
1677 Set oForm = SF_Register._NewForm(oXForm)
1678 With oForm
1679 Set .[_Parent] = [Me]
1680 ._SheetName = SheetName
1681 ._FormType = ISCALCFORM
1682 Set ._Component = _Component
1683 ._Initialize()
1684 End With
1685 Set Forms = oForm
1686 End If
1688 Finally:
1689 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1690 Exit Function
1691 Catch:
1692 GoTo Finally
1693 CatchNotFound:
1694 ScriptForge.SF_Exception.RaiseFatal(CALCFORMNOTFOUNDERROR, Form, _FileIdent())
1695 End Function ' SFDocuments.SF_Calc.Forms
1697 REM -----------------------------------------------------------------------------
1698 Function GetColumnName(Optional ByVal ColumnNumber As Variant) As String
1699 ''' Convert a column number (range 1, 2,..16384) into its letter counterpart (range 'A', 'B',..'XFD').
1700 ''' Args:
1702 ''' Returns:
1703 ''' a string representation of the column name, in range 'A'..'XFD'
1704 ''' If ColumnNumber is not in the allowed range, returns a zero-length string
1705 ''' Example:
1707 ''' Adapted from a Python function by sundar nataraj
1708 ''' http://stackoverflow.com/questions/23861680/convert-spreadsheet-number-to-column-letter
1710 Dim sCol As String ' Return value
1714 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1715 sCol = ""
1717 Check:
1718 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1720 End If
1722 Try:
1723 If (ColumnNumber > 0) And (ColumnNumber <= MAXCOLS) Then sCol = _GetColumnName(ColumnNumber)
1725 Finally:
1726 GetColumnName = sCol
1727 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1728 Exit Function
1729 Catch:
1730 GoTo Finally
1731 End Function ' SFDocuments.SF_Calc.GetColumnName
1733 REM -----------------------------------------------------------------------------
1734 Public Function GetFormula(Optional ByVal Range As Variant) As Variant
1735 ''' Get the formula(e) stored in the given range of cells
1736 ''' Args:
1737 ''' Range : the range as a string where to get the formula from
1738 ''' Returns:
1740 ''' Examples:
1743 Dim vGet As Variant ' Return value
1744 Dim oAddress As Object ' Alias of Range
1745 Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property
1749 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1750 vGet = Empty
1752 Check:
1753 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1754 If Not _IsStillAlive() Then GoTo Finally
1756 End If
1758 Try:
1759 ' Get the data
1760 Set oAddress = _ParseAddress(Range)
1761 vDataArray = oAddress.XCellRange.getFormulaArray()
1763 ' Convert the data array to scalar, vector or array
1764 vGet = ScriptForge.SF_Array.ConvertFromDataArray(vDataArray)
1766 Finally:
1767 GetFormula = vGet
1768 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1769 Exit Function
1770 Catch:
1771 GoTo Finally
1772 End Function ' SFDocuments.SF_Calc.GetFormula
1774 REM -----------------------------------------------------------------------------
1775 Public Function GetProperty(Optional ByVal PropertyName As Variant _
1776 , Optional ObjectName As Variant _
1777 ) As Variant
1778 ''' Return the actual value of the given property
1779 ''' Args:
1780 ''' PropertyName: the name of the property as a string
1781 ''' ObjectName: a sheet or range name
1782 ''' Returns:
1783 ''' The actual value of the property
1784 ''' Exceptions:
1785 ''' ARGUMENTERROR The property does not exist
1788 Const cstSubArgs = ""
1790 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1791 GetProperty = Null
1793 Check:
1794 If IsMissing(ObjectName) Or IsEMpty(ObjectName) Then ObjectName = ""
1795 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1796 If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
1797 If Not ScriptForge.SF_Utils._Validate(ObjectName, "ObjectName", V_STRING) Then GoTo Catch
1798 End If
1800 Try:
1801 ' Superclass or subclass property ?
1802 If ScriptForge.SF_Array.Contains([_Super].Properties(), PropertyName) Then
1803 GetProperty = [_Super].GetProperty(PropertyName)
1804 ElseIf Len(ObjectName) = 0 Then
1805 GetProperty = _PropertyGet(PropertyName)
1806 Else
1807 GetProperty = _PropertyGet(PropertyName, ObjectName)
1808 End If
1810 Finally:
1811 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1812 Exit Function
1813 Catch:
1814 GoTo Finally
1815 End Function ' SFDocuments.SF_Calc.GetProperty
1817 REM -----------------------------------------------------------------------------
1818 Public Function GetValue(Optional ByVal Range As Variant) As Variant
1819 ''' Get the value(s) stored in the given range of cells
1820 ''' Args:
1821 ''' Range : the range as a string where to get the value from
1822 ''' Returns:
1823 ''' A scalar, a zero-based 1D array or a zero-based 2D array of strings and doubles
1824 ''' To convert doubles to dates, use the CDate builtin function
1825 ''' Examples:
1828 Dim vGet As Variant ' Return value
1829 Dim oAddress As Object ' Alias of Range
1830 Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property
1834 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1835 vGet = Empty
1837 Check:
1838 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1839 If Not _IsStillAlive() Then GoTo Finally
1841 End If
1843 Try:
1844 ' Get the data
1845 Set oAddress = _ParseAddress(Range)
1846 vDataArray = oAddress.XCellRange.getDataArray()
1848 ' Convert the data array to scalar, vector or array
1849 vGet = ScriptForge.SF_Array.ConvertFromDataArray(vDataArray)
1851 Finally:
1852 GetValue = vGet
1853 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1854 Exit Function
1855 Catch:
1856 GoTo Finally
1857 End Function ' SFDocuments.SF_Calc.GetValue
1859 REM -----------------------------------------------------------------------------
1860 Public Function ImportFromCSVFile(Optional ByVal FileName As Variant _
1861 , Optional ByVal DestinationCell As Variant _
1862 , Optional ByVal FilterOptions As Variant _
1863 ) As String
1864 ''' Import the content of a CSV-formatted text file starting from a given cell
1865 ''' Beforehand the destination area will be cleared from any content and format
1866 ''' Args:
1867 ''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation
1868 ''' DestinationCell: the destination of the copied range of cells, as a string
1869 ''' If given as range, the destination will be reduced to its top-left cell
1870 ''' FilterOptions: The arguments of the CSV input filter.
1871 ''' Read https://wiki.documentfoundation.org/Documentation/DevGuide/Spreadsheet_Documents#Filter_Options_for_the_CSV_Filter
1872 ''' Default: input file encoding is UTF8
1873 ''' separator = comma, semi-colon or tabulation
1874 ''' string delimiter = double quote
1875 ''' all lines are included
1876 ''' quoted strings are formatted as texts
1877 ''' special numbers are detected
1878 ''' all columns are presumed texts
1879 ''' language = english/US => decimal separator is ".", thousands separator = ","
1880 ''' Returns:
1881 ''' A string representing the modified range of cells
1882 ''' The modified area depends only on the content of the source file
1883 ''' Exceptions:
1884 ''' DOCUMENTOPENERROR The csv file could not be opened
1885 ''' Examples:
1886 ''' oDoc.ImportFromCSVFile("C:\Temp\myCsvFile.csv", "SheetY.C5")
1888 Dim sImport As String ' Return value
1889 Dim oUI As Object ' UI service
1890 Dim oSource As Object ' New Calc document with csv loaded
1891 Dim oSelect As Object ' Current selection in destination
1896 Const cstSubArgs = "FileName, DestinationCell, [FilterOptions]=""9/44/59/MRG,34,76,1,,1033,true,true"""
1898 ' If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1899 sImport = ""
1901 Check:
1902 If IsMissing(FilterOptions) Or IsEmpty(FilterOptions) Then FilterOptions = cstFilterOptions
1903 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1904 If Not _IsStillAlive(True) Then GoTo Finally
1906 If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally
1907 End If
1909 Try:
1910 ' Input file is loaded in an empty worksheet. Data are copied to destination cell
1912 Set oSource = oUI.OpenDocument(FileName _
1913 , ReadOnly := True _
1914 , Hidden := True _
1915 , FilterName := cstFilter _
1916 , FilterOptions := FilterOptions _
1917 )
1918 ' Remember current selection and restore it after copy
1919 Set oSelect = _Component.CurrentController.getSelection()
1921 _RestoreSelections(_Component, oSelect)
1923 Finally:
1924 If Not IsNull(oSource) Then oSource.CloseDocument(False)
1925 ImportFromCSVFile = sImport
1926 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1927 Exit Function
1928 Catch:
1929 GoTo Finally
1930 End Function ' SFDocuments.SF_Calc.ImportFromCSVFile
1932 REM -----------------------------------------------------------------------------
1933 Public Sub ImportFromDatabase(Optional ByVal FileName As Variant _
1934 , Optional ByVal RegistrationName As Variant _
1935 , Optional ByVal DestinationCell As Variant _
1936 , Optional ByVal SQLCommand As Variant _
1937 , Optional ByVal DirectSQL As Variant _
1938 )
1939 ''' Import the content of a database table, query or resultset, i.e. the result of a SELECT SQL command,
1940 ''' starting from a given cell
1941 ''' Beforehand the destination area will be cleared from any content and format
1942 ''' The modified area depends only on the content of the source data
1943 ''' Args:
1944 ''' FileName: Identifies the file to open. It must follow the SF_FileSystem.FileNaming notation
1945 ''' RegistrationName: the name of a registered database
1947 ''' DestinationCell: the destination of the copied range of cells, as a string
1948 ''' If given as a range of cells, the destination will be reduced to its top-left cell
1949 ''' SQLCommand: either a table or query name (without square brackets)
1950 ''' or a full SQL commands where table and fieldnames are preferably surrounded with square brackets
1951 ''' Returns:
1952 ''' Implemented as a Sub because the doImport UNO method does not return any error
1953 ''' Exceptions:
1954 ''' BASEDOCUMENTOPENERROR The database file could not be opened
1955 ''' Examples:
1956 ''' oDoc.ImportFromDatabase("C:\Temp\myDbFile.odb", , "SheetY.C5", "SELECT * FROM [Employees] ORDER BY [LastName]")
1958 Dim oDBContext As Object ' com.sun.star.sdb.DatabaseContext
1959 Dim oDatabase As Object ' SFDatabases.Database service
1960 Dim lCommandType As Long ' A com.sun.star.sheet.DataImportMode.xxx constant
1961 Dim oQuery As Object ' com.sun.star.ucb.XContent
1962 Dim bDirect As Boolean ' Alias of DirectSQL
1963 Dim oDestRange As Object ' Destination as a range
1964 Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress
1965 Dim oDestCell As Object ' com.sun.star.table.XCell
1966 Dim oSelect As Object ' Current selection in destination
1967 Dim vImportOptions As Variant ' Array of PropertyValues
1970 Const cstSubArgs = "[FileName=""""], [RegistrationName=""""], DestinationCell, SQLCommand, [DirectSQL=False]"
1972 ' If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1974 Check:
1976 If IsMissing(FileName) Or IsEmpty(FileName) Then FileName = ""
1977 If IsMissing(RegistrationName) Or IsEmpty(RegistrationName) Then RegistrationName = ""
1978 If IsMissing(DirectSQL) Or IsEmpty(DirectSQL) Then DirectSQL = False
1979 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1980 If Not _IsStillAlive(True) Then GoTo Finally
1981 If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName", , True) Then GoTo Finally
1982 If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally
1983 If Not ScriptForge.SF_Utils._Validate(SQLCommand, "SQLCommand", V_STRING) Then GoTo Finally
1984 If Not ScriptForge.SF_Utils._Validate(DirectSQL, "DirectSQL", ScriptForge.V_BOOLEAN) Then GoTo Finally
1985 End If
1987 ' Check the existence of FileName
1989 If Len(RegistrationName) = 0 Then GoTo CatchError
1991 If Not oDBContext.hasRegisteredDatabase(RegistrationName) Then GoTo CatchError
1992 FileName = ScriptForge.SF_FileSystem._ConvertFromUrl(oDBContext.getDatabaseLocation(RegistrationName))
1993 End If
1994 If Not ScriptForge.SF_FileSystem.FileExists(FileName) Then GoTo CatchError
1996 Try:
1997 ' Check command type
1998 Set oDatabase = ScriptForge.SF_Services.CreateScriptService("SFDatabases.Database", FileName, , True) ' Read-only
1999 If IsNull(oDatabase) Then GoTo CatchError
2000 With oDatabase
2001 If ScriptForge.SF_Array.Contains(.Tables, SQLCommand) Then
2002 bDirect = True
2003 lCommandType = com.sun.star.sheet.DataImportMode.TABLE
2004 ElseIf ScriptForge.SF_Array.Contains(.Queries, SQLCommand) Then
2005 Set oQuery = .XConnection.Queries.getByName(SQLCommand)
2006 bDirect = Not oQuery.EscapeProcessing
2007 lCommandType = com.sun.star.sheet.DataImportMode.QUERY
2008 Else
2009 bDirect = DirectSQL
2010 lCommandType = com.sun.star.sheet.DataImportMode.SQL
2011 SQLCommand = ._ReplaceSquareBrackets(SQLCommand)
2012 End If
2013 .CloseDatabase()
2014 Set oDatabase = oDatabase.Dispose()
2015 End With
2017 ' Determine the destination cell as the top-left coordinates of the given range
2018 Set oDestRange = _ParseAddress(DestinationCell)
2019 Set oDestAddress = oDestRange.XCellRange.RangeAddress
2020 Set oDestCell = oDestRange.XSpreadsheet.getCellByPosition(oDestAddress.StartColumn, oDestAddress.StartRow)
2022 ' Remember current selection
2023 Set oSelect = _Component.CurrentController.getSelection()
2024 ' Import arguments
2025 vImportOptions = Array(_
2026 ScriptForge.SF_Utils._MakePropertyValue("DatabaseName", ScriptForge.SF_FileSystem._ConvertToUrl(FileName)) _
2030 )
2031 oDestCell.doImport(vImportOptions)
2032 ' Restore selection after import_
2033 _RestoreSelections(_Component, oSelect)
2035 Finally:
2036 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2037 Exit Sub
2038 Catch:
2039 GoTo Finally
2040 CatchError:
2041 SF_Exception.RaiseFatal(BASEDOCUMENTOPENERROR, "FileName", FileName, "RegistrationName", RegistrationName)
2042 GoTo Finally
2043 End Sub ' SFDocuments.SF_Calc.ImportFromDatabase
2045 REM -----------------------------------------------------------------------------
2046 Public Function InsertSheet(Optional ByVal SheetName As Variant _
2047 , Optional ByVal BeforeSheet As Variant _
2048 ) As Boolean
2049 ''' Insert a new empty sheet before an existing sheet or at the end of the list of sheets
2050 ''' Args:
2051 ''' SheetName: The name of the new sheet
2052 ''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to insert
2053 ''' Returns:
2054 ''' True if the sheet could be inserted successfully
2055 ''' Examples:
2058 Dim bInsert As Boolean ' Return value
2059 Dim vSheets As Variant ' List of existing sheets
2060 Dim lSheetIndex As Long ' Index of a sheet
2064 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2065 bInsert = False
2067 Check:
2068 If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768
2069 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2070 If Not _IsStillAlive(True) Then GoTo Finally
2073 End If
2074 vSheets = _Component.getSheets.getElementNames()
2076 Try:
2077 If VarType(BeforeSheet) = V_STRING Then
2078 lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet)
2079 Else
2080 lSheetIndex = BeforeSheet - 1
2083 End If
2084 _Component.getSheets.insertNewByName(SheetName, lSheetIndex)
2085 bInsert = True
2087 Finally:
2088 InsertSheet = binsert
2089 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2090 Exit Function
2091 Catch:
2092 GoTo Finally
2093 End Function ' SFDocuments.SF_Calc.InsertSheet
2095 REM -----------------------------------------------------------------------------
2096 Public Function Intersect(Optional ByVal Range1 As Variant _
2097 , Optional ByVal Range2 As Variant _
2098 ) As String
2099 ''' Returns the cell range as a string that is common to the input ranges
2100 ''' Args:
2101 ''' Range1: a first range as a string
2102 ''' Range2: a second range as a string
2103 ''' Returns:
2104 ''' The intersection, as a string, representing the range common to both input ranges,
2105 ''' or a zero-length string when the intersection is empty.
2106 ''' Example:
2108 ''' ' $Sheet2.$L$10:$M$11 when Sheet2 is the current sheet, otherwise the empty string
2110 Dim sIntersect As String ' Return value
2111 Dim oRangeAddress1 As Object ' SF_UI._Address type
2112 Dim oRangeAddress2 As Object ' SF_UI._Address type
2113 Dim oRange1 As Object ' com.sun.star.table.CellRangeAddress
2114 Dim oRange2 As Object ' com.sun.star.table.CellRangeAddress
2115 Dim lStartRow As Long ' Intersection starting row
2116 Dim lEndRow As Long ' Intersection ending row
2117 Dim lStartColumn As Long ' Intersection starting column
2118 Dim lEndColumn As Long ' Intersection ending column
2123 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2124 sIntersect = ""
2126 Check:
2127 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2128 If Not _IsStillAlive(True) Then GoTo Finally
2131 End If
2133 Set oRangeAddress1 = _ParseAddress(Range1)
2134 Set oRange1 = oRangeAddress1.XCellRange.RangeAddress
2135 Set oRangeAddress2 = _ParseAddress(Range2)
2136 Set oRange2 = oRangeAddress2.XCellRange.RangeAddress
2138 If oRangeAddress1.SheetName <> oRangeAddress2.SheetName Then GoTo Finally
2140 Try:
2141 ' Find the top-left and bottom-right coordinates of the intersection
2142 lStartRow = Iif(oRange1.StartRow > oRange2.StartRow, oRange1.StartRow, oRange2.StartRow) + 1
2143 lStartColumn = Iif(oRange1.StartColumn > oRange2.StartColumn, oRange1.StartColumn, oRange2.StartColumn) + 1
2145 lEndColumn = Iif(oRange1.EndColumn < oRange2.EndColumn, oRange1.EndColumn, oRange2.EndColumn) + 1
2149 sIntersect = A1Style(lStartRow, lStartColumn, lEndRow, lEndColumn, oRangeAddress1.SheetName)
2150 End If
2152 Finally:
2153 Intersect = sIntersect
2154 'ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2155 Exit Function
2156 Catch:
2157 GoTo Finally
2158 End Function ' SFDocuments.SF_Calc.Intersect
2160 REM -----------------------------------------------------------------------------
2161 Public Function Methods() As Variant
2162 ''' Return the list of public methods of the Calc service as an array
2164 Methods = Array( _
2206 )
2208 End Function ' SFDocuments.SF_Calc.Methods
2210 REM -----------------------------------------------------------------------------
2211 Public Function MoveRange(Optional ByVal Source As Variant _
2212 , Optional ByVal Destination As Variant _
2213 ) As String
2214 ''' Move a specified source range to a destination range
2215 ''' Args:
2216 ''' Source: the source range of cells as a string
2217 ''' Destination: the destination of the moved range of cells, as a string
2218 ''' If given as a range of cells, the destination will be reduced to its top-left cell
2219 ''' Returns:
2220 ''' A string representing the modified range of cells
2221 ''' The modified area depends only on the size of the source area
2222 ''' Examples:
2225 Dim sMove As String ' Return value
2226 Dim oSource As Object ' Alias of Source to avoid "Object variable not set" run-time error
2227 Dim oSourceAddress As Object ' com.sun.star.table.CellRangeAddress
2228 Dim oDestRange As Object ' Destination as a range
2229 Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress
2230 Dim oDestCell As Object ' com.sun.star.table.CellAddress
2231 Dim oSelect As Object ' Current selection in source
2232 Dim oClipboard As Object ' com.sun.star.datatransfer.XTransferable
2233 Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges
2234 Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress
2235 Dim i As Long
2240 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2241 sMove = ""
2243 Check:
2244 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2245 If Not _IsStillAlive(True) Then GoTo Finally
2248 End If
2250 Try:
2251 Set oSourceAddress = _ParseAddress(Source).XCellRange.RangeAddress
2252 Set oDestRange = _ParseAddress(Destination)
2253 Set oDestAddress = oDestRange.XCellRange.RangeAddress
2254 Set oDestCell = New com.sun.star.table.CellAddress
2255 With oDestAddress
2256 oDestCell.Sheet = .Sheet
2257 oDestCell.Column = .StartColumn
2258 oDestCell.Row = .StartRow
2259 End With
2260 oDestRange.XSpreadsheet.moveRange(oDestCell, oSourceAddress)
2262 With oSourceAddress
2263 sMove = _Offset(Destination, 0, 0, .EndRow - .StartRow + 1, .EndColumn - .StartColumn + 1).RangeName
2264 End With
2266 Finally:
2267 MoveRange = sMove
2268 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2269 Exit Function
2270 Catch:
2271 GoTo Finally
2272 End Function ' SFDocuments.SF_Calc.MoveRange
2274 REM -----------------------------------------------------------------------------
2275 Public Function MoveSheet(Optional ByVal SheetName As Variant _
2276 , Optional ByVal BeforeSheet As Variant _
2277 ) As Boolean
2278 ''' Move a sheet before an existing sheet or at the end of the list of sheets
2279 ''' Args:
2280 ''' SheetName: The name of the sheet to move
2281 ''' BeforeSheet: The name (string) or index (numeric, starting from 1) of the sheet before which to move the sheet
2282 ''' Returns:
2283 ''' True if the sheet could be moved successfully
2284 ''' Examples:
2287 Dim bMove As Boolean ' Return value
2288 Dim vSheets As Variant ' List of existing sheets
2289 Dim lSheetIndex As Long ' Index of a sheet
2293 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2294 bMove = False
2296 Check:
2297 If IsMissing(BeforeSheet) Or IsEmpty(BeforeSheet) Then BeforeSheet = 32768
2298 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2299 If Not _IsStillAlive(True) Then GoTo Finally
2302 End If
2303 vSheets = _Component.getSheets.getElementNames()
2305 Try:
2306 If VarType(BeforeSheet) = V_STRING Then
2307 lSheetIndex = ScriptForge.SF_Array.IndexOf(vSheets, BeforeSheet)
2308 Else
2309 lSheetIndex = BeforeSheet - 1
2312 End If
2313 _Component.getSheets.MoveByName(SheetName, lSheetIndex)
2314 bMove = True
2316 Finally:
2317 MoveSheet = bMove
2318 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2319 Exit Function
2320 Catch:
2321 GoTo Finally
2322 End Function ' SFDocuments.SF_Calc.MoveSheet
2324 REM -----------------------------------------------------------------------------
2325 Public Function Offset(Optional ByRef Range As Variant _
2326 , Optional ByVal Rows As Variant _
2327 , Optional ByVal Columns As Variant _
2328 , Optional ByVal Height As Variant _
2329 , Optional ByVal Width As Variant _
2330 ) As String
2331 ''' Returns a new range offset by a certain number of rows and columns from a given range
2332 ''' Args:
2333 ''' Range : the range, as a string, from which the function searches for the new range
2334 ''' Rows : the number of rows by which the reference was corrected up (negative value) or down.
2336 ''' Columns : the number of columns by which the reference was corrected to the left (negative value) or to the right.
2338 ''' Height : the vertical height for an area that starts at the new reference position.
2339 ''' Default = no vertical resizing
2340 ''' Width : the horizontal width for an area that starts at the new reference position.
2341 ''' Default - no horizontal resizing
2342 ''' Arguments Rows and Columns must not lead to zero or negative start row or column.
2343 ''' Arguments Height and Width must not lead to zero or negative count of rows or columns.
2344 ''' Returns:
2345 ''' A new range as a string
2346 ''' Exceptions:
2347 ''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries
2348 ''' Examples:
2349 ''' oDoc.Offset("A1", 2, 2) ' "'SheetX'.$C$3" (A1 moved by two rows and two columns down)
2350 ''' oDoc.Offset("A1", 2, 2, 5, 6) ' "'SheetX'.$C$3:$H$7"
2352 Dim sOffset As String ' Return value
2353 Dim oAddress As Object ' Alias of Range
2357 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2358 sOffset = ""
2360 Check:
2361 If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0
2362 If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0
2363 If IsMissing(Height) Or IsEmpty(Height) Then Height = 0
2364 If IsMissing(Width) Or IsEmpty(Width) Then Width = 0
2365 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2366 If Not _IsStillAlive() Then GoTo Finally
2368 If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally
2369 If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally
2370 If Not ScriptForge.SF_Utils._Validate(Height, "Height", ScriptForge.V_NUMERIC) Then GoTo Finally
2371 If Not ScriptForge.SF_Utils._Validate(Width, "Width", ScriptForge.V_NUMERIC) Then GoTo Finally
2372 End If
2374 Try:
2375 ' Define the new range string
2376 Set oAddress = _Offset(Range, Rows, Columns, Height, Width)
2377 sOffset = oAddress.RangeName
2379 Finally:
2380 Offset = sOffset
2381 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2382 Exit Function
2383 Catch:
2384 GoTo Finally
2385 End Function ' SFDocuments.SF_Calc.Offset
2387 REM -----------------------------------------------------------------------------
2388 Public Function OpenRangeSelector(Optional ByVal Title As Variant _
2389 , Optional ByVal Selection As Variant _
2390 , Optional ByVal SingleCell As Variant _
2391 , Optional ByVal CloseAfterSelect As Variant _
2392 ) As String
2393 ''' Activates the Calc document, opens a non-modal dialog with a text box,
2394 ''' let the user make a selection in the current or another sheet and
2395 ''' returns the selected area as a string.
2396 ''' This method does not change the current selection.
2397 ''' Args:
2398 ''' Title: the title to display on the top of the dialog
2399 ''' Selection: a default preselection as a String. When absent, the first element of the
2400 ''' current selection is preselected.
2401 ''' SingleCell: When True, only a single cell may be selected. Default = False
2402 ''' CloseAfterSelect: When True (default-, the dialog is closed immediately after
2403 ''' the selection. When False, the user may change his/her mind and must close
2404 ''' the dialog manually.
2405 ''' Returns:
2406 ''' The selected range as a string, or the empty string when the user cancelled the request (close window button)
2407 ''' Exceptions:
2408 ''' Examples:
2409 ''' Dim sSelect As String, vValues As Variant
2412 ''' vValues = oDoc.GetValue(sSelect)
2414 Dim sSelector As String ' Return value
2415 Dim vPropertyValues As Variant ' Array of com.sun.star.beans.PropertyValue
2416 Dim oSelection As Object ' The current selection before opening the selector
2417 Dim oAddress As Object ' Preselected address as _Address
2420 Const cstSubArgs = "[Title=""""], [Selection=""~""], [SingleCell=False], [CloseAfterSelect=True]"
2422 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2423 sSelector = ""
2425 Check:
2426 If IsMissing(Title) Or IsEmpty(Title) Then Title = ""
2428 If IsMissing(SingleCell) Or IsEmpty(SingleCell) Then SingleCell = False
2429 If IsMissing(CloseAfterSelect) Or IsEmpty(CloseAfterSelect) Then CloseAfterSelect = True
2430 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2431 If Not _IsStillAlive() Then GoTo Finally
2433 If Not ScriptForge.SF_Utils._Validate(Selection, "Selection", V_STRING) Then GoTo Finally
2434 If Not ScriptForge.SF_Utils._Validate(SingleCell, "SingleCell", ScriptForge.V_BOOLEAN) Then GoTo Finally
2435 If Not ScriptForge.SF_Utils._Validate(CloseAfterSelect, "CloseAfterSelect", ScriptForge.V_BOOLEAN) Then GoTo Finally
2436 End If
2438 Try:
2439 ' Save the current selections
2440 Set oSelection = _Component.CurrentController.getSelection()
2442 ' Process preselection and select its containing sheet
2443 Set oAddress = _ParseAddress(Selection)
2444 Activate(oAddress.SheetName)
2446 ' Build arguments array and execute the dialog box
2447 With ScriptForge.SF_Utils
2448 vPropertyValues = Array( _
2453 )
2454 End With
2455 sSelector = SF_DocumentListener.RunRangeSelector(_Component, vPropertyValues)
2457 ' Restore the saved selections
2458 _RestoreSelections(_Component, oSelection)
2460 Finally:
2461 OpenRangeSelector = sSelector
2462 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2463 Exit Function
2464 Catch:
2465 GoTo Finally
2466 End Function ' SFDocuments.SF_Calc.OpenRangeSelector
2468 REM -----------------------------------------------------------------------------
2469 Public Function Printf(Optional ByVal InputStr As Variant _
2470 , Optional ByVal Range As Variant _
2471 , Optional ByVal TokenCharacter As Variant _
2472 ) As String
2473 ''' Returns the input string after substitution of its tokens by
2474 ''' their values in the given range
2475 ''' This method is usually used in combination with SetFormula()
2476 ''' The accepted tokens are:
2477 ''' - %S The sheet name containing the range, including single quotes when necessary
2478 ''' - %R1 The row number of the topleft part of the range
2479 ''' - %C1 The column letter of the topleft part of the range
2480 ''' - %R2 The row number of the bottomright part of the range
2481 ''' - %C2 The column letter of the bottomright part of the range
2482 ''' Args:
2483 ''' InputStr: usually a Calc formula or a part of a formula, but may be any string
2484 ''' Range: the range, as a string from which the values of the tokens are derived
2486 ''' Double the TokenCharacter to not consider it as a token.
2487 ''' Returns:
2488 ''' The input string after substitution of the contained tokens
2489 ''' Exceptions:
2490 ''' Examples:
2491 ''' Assume we have in A1:E10 a matrix of numbers. To obtain the sum by row in F1:F10 ...
2492 ''' Dim range As String, formula As String
2494 ''' formula = "=SUM($%C1%R1:$%C2%R1)" ' "=SUM($A1:$E1)", note the relative references
2496 ''' 'F1 will contain =Sum($A1:$E1)
2497 ''' 'F2 =Sum($A2:$E2)
2498 ''' ' ...
2500 Dim sPrintf As String ' Return value
2501 Dim vSubstitute As Variants ' Array of strings representing the token values
2502 Dim oAddress As Object ' A range as an _Address object
2503 Dim sSheetName As String ' The %S token value
2504 Dim sC1 As String ' The %C1 token value
2505 Dim sR1 As String ' The %R1 token value
2506 Dim sC2 As String ' The %C2 token value
2507 Dim sR2 As String ' The %R2 token value
2508 Dim i As Long
2514 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2515 sPrintf = ""
2517 Check:
2519 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2520 If Not _IsStillAlive() Then GoTo Finally
2521 If Not ScriptForge.SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally
2523 If Not ScriptForge.SF_Utils._Validate(TokenCharacter, "TokenCharacter", V_STRING) Then GoTo Finally
2524 End If
2526 Try:
2527 ' Define the token values
2528 Set oAddress = _ParseAddress(Range)
2529 With oAddress.XCellRange
2530 sC1 = _GetColumnName(.RangeAddress.StartColumn + 1)
2531 sR1 = CStr(.RangeAddress.StartRow + 1)
2532 sC2 = _GetColumnName(.RangeAddress.EndColumn + 1)
2533 sR2 = CStr(.RangeAddress.EndRow + 1)
2534 sSheetName = _QuoteSheetName(oAddress.XSpreadsheet.Name)
2535 End With
2537 ' Substitute tokens by their values
2538 sPrintf = ScriptForge.SF_String.ReplaceStr(InputStr _
2539 , Array(TokenCharacter & TokenCharacter _
2545 , cstPseudoToken _
2546 ) _
2547 , Array(cstPseudoToken _
2548 , sR1 _
2549 , sC1 _
2550 , sR2 _
2551 , sC2 _
2552 , sSheetName _
2553 , TokenCharacter _
2554 ) _
2555 )
2557 Finally:
2558 Printf = sPrintf
2559 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2560 Exit Function
2561 Catch:
2562 GoTo Finally
2563 End Function ' SFDocuments.SF_Calc.Printf
2565 REM -----------------------------------------------------------------------------
2566 Public Function PrintOut(Optional ByVal SheetName As Variant _
2567 , Optional ByVal Pages As Variant _
2568 , Optional ByVal Copies As Variant _
2569 ) As Boolean
2570 ''' Send the content of the given sheet to the printer.
2571 ''' The printer might be defined previously by default, by the user or by the SetPrinter() method
2572 ''' Args:
2573 ''' SheetName: the sheet to print. Default = the active sheet
2574 ''' Pages: the pages to print as a string, like in the user interface. Example: "1-4;10;15-18". Default = all pages
2575 ''' Copies: the number of copies
2576 ''' Returns:
2577 ''' True when successful
2578 ''' Examples:
2581 Dim bPrint As Boolean ' Return value
2582 Dim oSheet As Object ' SheetName as a reference
2585 Const cstSubArgs = "[SheetName=""~""], [Pages=""""], [Copies=1]"
2587 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2588 bPrint = False
2590 Check:
2591 If IsMissing(SheetName) Or IsEmpty(SheetName) Then SheetName = ""
2592 If IsMissing(Pages) Or IsEmpty(Pages) Then Pages = ""
2593 If IsMissing(Copies) Or IsEmpty(Copies) Then Copies = 1
2595 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2596 If Not _IsStillAlive() Then GoTo Finally
2599 If Not ScriptForge.SF_Utils._Validate(Copies, "Copies", ScriptForge.V_NUMERIC) Then GoTo Finally
2600 End If
2602 Try:
2604 ' Make given sheet active
2606 With _Component
2607 Set oSheet = .getSheets.getByName(SheetName)
2608 Set .CurrentController.ActiveSheet = oSheet
2609 End With
2610 End If
2612 bPrint = [_Super].PrintOut(Pages, Copies, _Component)
2614 Finally:
2615 PrintOut = bPrint
2616 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2617 Exit Function
2618 Catch:
2619 GoTo Finally
2620 End Function ' SFDocuments.SF_Calc.PrintOut
2622 REM -----------------------------------------------------------------------------
2623 Public Function Properties() As Variant
2624 ''' Return the list or properties of the Calc class as an array
2626 Properties = Array( _
2667 )
2669 End Function ' SFDocuments.SF_Calc.Properties
2671 REM -----------------------------------------------------------------------------
2672 Public Function RemoveDuplicates(Optional ByVal Range As Variant _
2673 , Optional ByVal Columns As Variant _
2674 , Optional ByVal Header As Variant _
2675 , Optional ByVal CaseSensitive As Variant _
2676 , Optional ByVal Mode As Variant _
2677 ) As String
2678 ''' Remove duplicate values from a range of values.
2679 ''' The comparison between rows is done on a subset of the columns in the range.
2680 ''' The resulting range replaces the input range, in which, either:
2681 ''' all duplicate rows are cleared from their content
2682 ''' all duplicate rows are suppressed and rows below are pushed upwards.
2683 ''' Anyway, the first copy of each set of duplicates is kept and the initial sequence is preserved.
2684 ''' Args:
2685 ''' Range: the range, as a string, from which the duplicate rows should be removed
2686 ''' Columns: an array of column numbers to compare; items are in the interval [1 .. range width]
2687 ''' Default = the first column in the range
2688 ''' Header: when True, the first row is a header row. Default = False.
2689 ''' CaseSensitive: for string comparisons. Default = False.
2691 ''' For large ranges, the "COMPACT" mode is probably significantly slower.
2692 ''' Returns:
2693 ''' The resulting range as a string
2694 ''' Examples:
2695 ''' oCalc.RemoveDuplicates("Sheet1.B2:K11", Array(1, 2), Header := True, CaseSensitive := True)
2697 Dim sRemove As String ' Return value
2698 Dim oRangeAddress As Object ' Parsed range as an _Address object
2699 Dim sMirrorRange As String ' Mirror of initial range
2700 Dim lRandom As Long ' Random number to build the worksheet name
2701 Dim sWorkSheet As String ' Name of worksheet
2702 Dim vRows() As Variant ' Array of row numbers
2703 Dim sRowsRange As String ' Range of the last column of the worksheet
2704 Dim sFullMirrorRange As String ' Mirrored data + rows column
2705 Dim sLastRowsRange As String ' Same as sRowsRange without the first cell
2706 Dim sDuplicates As String ' Formula identifying a duplicate row
2707 Dim lColumn As Long ' Single column number
2708 Dim sColumn As String ' Single column name
2709 Dim sFilter As String ' Filter formula for final compaction or clearing
2712 Const cstSubArgs = "Range, [Columns], [Header=False], [CaseSensitive=False], [Mode=""COMPACT""|""CLEAR""]"
2714 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2715 sRemove = ""
2717 Check:
2718 If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = Array(1)
2719 If Not IsArray(Columns) Then Columns = Array(Columns)
2720 If IsMissing(Header) Or IsEmpty(Header) Then Header = False
2721 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
2723 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2724 If Not _IsStillAlive(True) Then GoTo Finally
2726 If Not ScriptForge.SF_Utils._ValidateArray(Columns, "Columns", 1, ScriptForge.V_NUMERIC, True) Then GoTo Finally
2727 If Not ScriptForge.SF_Utils._Validate(Header, "Header", ScriptForge.V_BOOLEAN) Then GoTo Finally
2728 If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", ScriptForge.V_BOOLEAN) Then GoTo Finally
2729 If Not ScriptForge.SF_Utils._Validate(Mode, "Mode", V_STRING, Array("COMPACT", "CLEAR")) Then GoTo Finally
2730 End If
2732 Try:
2733 ' Let's assume the initial range is "$Sheet1.$B$11:$K$110" (100 rows, 10 columns, no header)
2734 ' Ignore header, consider only the effective data
2735 If Header Then Set oRangeAddress = _Offset(Range, 1, 0, Height(Range) - 1, 0) Else Set oRangeAddress = _ParseAddress(Range)
2740 InsertSheet(sWorkSheet)
2742 sMirrorRange = CopyToCell(oRangeAddress, "$" & sWorkSheet & ".$A$1")
2746 With oRangeAddress.XCellRange
2747 vRows = ScriptForge.RangeInit(CLng(.RangeAddress.StartRow + 1), CLng(.RangeAddress.EndRow + 1))
2748 End With
2754 sFullMirrorRange = Offset(sMirrorRange, , , , Width(sMirrorRange) + 1)
2755 SortRange(sFullMirrorRange, SortKeys := Columns, CaseSensitive := CaseSensitive)
2762 For Each lColumn In Columns
2763 sColumn = _GetColumnName(lColumn)
2764 If CaseSensitive Then
2765 sDuplicates = sDuplicates & ";$" & sColumn & "2=$" & sColumn & "1"
2766 Else
2767 sDuplicates = sDuplicates & ";UPPER($" & sColumn & "2)=UPPER($" & sColumn & "1)"
2768 End If
2769 Next lColumn
2773 '** Step 5: Compact or clear the rows in the initial range that are not retained in the final row numbers list
2776 Select Case UCase(Mode)
2778 sRemove = CompactUp(oRangeAddress.RangeName, WholeRow := False, FilterFormula := sFilter)
2782 If Header Then sRemove = _ParseAddress(Range).RangeName Else sRemove = oRangeAddress.RangeName
2783 End Select
2785 '** Housekeeping
2786 RemoveSheet(sWorkSheet)
2788 Finally:
2789 RemoveDuplicates = sRemove
2790 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2791 Exit Function
2792 Catch:
2793 GoTo Finally
2794 End Function ' SFDocuments.SF_Calc.RemoveDuplicates
2796 REM -----------------------------------------------------------------------------
2797 Public Function RemoveSheet(Optional ByVal SheetName As Variant) As Boolean
2798 ''' Remove an existing sheet from the document
2799 ''' Args:
2800 ''' SheetName: The name of the sheet to remove
2801 ''' Returns:
2802 ''' True if the sheet could be removed successfully
2803 ''' Examples:
2806 Dim bRemove As Boolean ' Return value
2810 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2811 bRemove = False
2813 Check:
2814 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2815 If Not _IsStillAlive(True) Then GoTo Finally
2817 End If
2819 Try:
2820 _Component.getSheets.RemoveByName(SheetName)
2821 bRemove = True
2823 Finally:
2824 RemoveSheet = bRemove
2825 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2826 Exit Function
2827 Catch:
2828 GoTo Finally
2829 End Function ' SFDocuments.SF_Calc.RemoveSheet
2831 REM -----------------------------------------------------------------------------
2832 Public Function RenameSheet(Optional ByVal SheetName As Variant _
2833 , Optional ByVal NewName As Variant _
2834 ) As Boolean
2835 ''' Rename a specified sheet
2836 ''' Args:
2837 ''' SheetName: The name of the sheet to rename
2838 ''' NewName: Must not exist
2839 ''' Returns:
2840 ''' True if the sheet could be renamed successfully
2841 ''' Exceptions:
2842 ''' DUPLICATESHEETERROR A sheet with the given name exists already
2843 ''' Examples:
2846 Dim bRename As Boolean ' Return value
2850 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2851 bRename = False
2853 Check:
2854 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2855 If Not _IsStillAlive(True) Then GoTo Finally
2858 End If
2860 Try:
2861 _Component.getSheets.getByName(SheetName).setName(NewName)
2862 bRename = True
2864 Finally:
2865 RenameSheet = bRename
2866 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2867 Exit Function
2868 Catch:
2869 GoTo Finally
2870 End Function ' SFDocuments.SF_Calc.RenameSheet
2872 REM -----------------------------------------------------------------------------
2873 Public Function SetArray(Optional ByVal TargetCell As Variant _
2874 , Optional ByRef Value As Variant _
2875 ) As String
2876 ''' Set the given (array of) values starting from the target cell
2877 ''' The updated area expands itself from the target cell or from the top-left corner of the given range
2878 ''' as far as determined by the size of the input Value.
2879 ''' Vectors are always expanded vertically
2880 ''' Args:
2881 ''' TargetCell : the cell or the range as a string that should receive a new value
2882 ''' Value: a scalar, a vector or an array with the new values
2883 ''' The new values should be strings, numeric values or dates. Other types empty the corresponding cell
2884 ''' Returns:
2885 ''' A string representing the updated range
2886 ''' Exceptions:
2887 ''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries
2888 ''' Examples:
2891 Dim sSet As String ' Return value
2892 Dim oSet As Object ' _Address alias of sSet
2893 Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property
2897 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2898 sSet = ""
2900 Check:
2901 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2902 If Not _IsStillAlive() Then GoTo Finally
2903 If Not ScriptForge.SF_Utils._Validate(TargetCell, "TargetCell", V_STRING) Then GoTo Finally
2904 If IsArray(Value) Then
2906 Else
2908 End If
2909 End If
2911 Try:
2912 ' Convert argument to data array and derive new range from its size
2913 vDataArray = ScriptForge.SF_Array.ConvertToDataArray(Value, IsRange := True)
2914 If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally
2915 Set oSet = _Offset(TargetCell, 0, 0, plHeight := UBound(vDataArray) + 1, plWidth := UBound(vDataArray(0)) + 1) ' +1 : vDataArray is zero-based
2916 With oSet
2917 .XCellRange.setDataArray(vDataArray)
2918 sSet = .RangeName
2919 End With
2921 Finally:
2922 SetArray = sSet
2923 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2924 Exit Function
2925 Catch:
2926 GoTo Finally
2927 End Function ' SFDocuments.SF_Calc.SetArray
2929 REM -----------------------------------------------------------------------------
2930 Public Function SetCellStyle(Optional ByVal TargetRange As Variant _
2931 , Optional ByVal Style As Variant _
2932 , Optional ByVal FilterFormula As Variant _
2933 , Optional ByVal FilterScope As Variant _
2934 ) As String
2935 ''' Apply the given cell style in the given range
2936 ''' If the cell style does not exist, an error is raised
2937 ''' The range is updated and the remainder of the sheet is left untouched
2938 ''' Either the full range is updated or a selection based on a FilterFormula
2939 ''' Args:
2940 ''' TargetRange : the range as a string that should receive a new cell style
2941 ''' Style: the style name as a string
2942 ''' FilterFormula: a Calc formula to select among the given Range
2943 ''' When left empty, all the cells of the range are formatted with the new style
2944 ''' FilterScope: "CELL" (default value), "ROW" or "COLUMN"
2945 ''' When FilterFormula is present, FilterScope is mandatory
2946 ''' Returns:
2947 ''' A string representing the updated range
2948 ''' Examples:
2950 ''' oDoc.SetCellStype("A1:J20", "Wrong", "=(A1<0)", "CELL")
2952 Dim sSet As String ' Return value
2953 Dim oAddress As _Address ' Alias of TargetRange
2954 Dim oStyleFamilies As Object ' com.sun.star.container.XNameAccess
2955 Dim vStyles As Variant ' Array of existing cell styles
2956 Dim vRanges() As Variant ' Array of filtered ranges
2957 Dim i As Long
2961 Const cstSubArgs = "TargetRange, Style, [FilterFormula=""], [FilterScope=""CELL""|""ROW""|""COLUMN""]"
2963 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
2964 sSet = ""
2966 Check:
2967 If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = ""
2969 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
2970 If Not _IsStillAlive() Then GoTo Finally
2971 If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally
2972 ' Check that the given style really exists
2973 Set oStyleFamilies = _Component.StyleFamilies
2974 If oStyleFamilies.hasByName(cstStyle) Then vStyles = oStyleFamilies.getByName(cstStyle).getElementNames() Else vStyles = Array()
2975 If Not ScriptForge.SF_Utils._Validate(Style, "Style", V_STRING, vStyles, True) Then GoTo Finally
2976 ' Filter formula
2977 If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally
2979 If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING, Array("CELL", "ROW", "COLUMN")) Then GoTo Finally
2980 Else
2981 If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING) Then GoTo Finally
2982 End If
2983 End If
2985 Try:
2986 If VarType(TargetRange) = V_STRING Then Set oAddress = _ParseAddress(TargetRange) Else Set oAddress = TargetRange
2987 With oAddress
2989 .XCellRange.CellStyle = Style
2990 Else ' When the range has to be cut in subranges
2991 vRanges() = _ComputeFilter(oAddress, FilterFormula, UCase(FilterScope))
2992 For i = 0 To UBound(vRanges)
2993 vRanges(i).XCellRange.CellStyle = Style
2994 Next i
2995 End If
2996 sSet = .RangeName
2997 End With
2999 Finally:
3000 SetCellStyle = sSet
3001 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
3002 Exit Function
3003 Catch:
3004 GoTo Finally
3005 End Function ' SFDocuments.SF_Calc.SetCellStyle
3007 REM -----------------------------------------------------------------------------
3008 Public Function SetFormula(Optional ByVal TargetRange As Variant _
3009 , Optional ByRef Formula As Variant _
3010 ) As String
3011 ''' Set the given (array of) formulae in the given range
3012 ''' The full range is updated and the remainder of the sheet is left untouched
3013 ''' If the given formula is a string:
3014 ''' the unique formula is pasted across the whole range with adjustment of the relative references
3015 ''' Otherwise
3016 ''' If the size of Formula < the size of Range, then the other cells are emptied
3017 ''' If the size of Formula > the size of Range, then Formula is only partially copied
3018 ''' Vectors are always expanded vertically, except if the range has a height of exactly 1 row
3019 ''' Args:
3020 ''' TargetRange : the range as a string that should receive a new Formula
3021 ''' Formula: a scalar, a vector or an array with the new formula(e) as strings for each cell of the range.
3022 ''' Returns:
3023 ''' A string representing the updated range
3024 ''' Examples:
3026 ''' oDoc.SetFormula("A1:F1", Array("=A2", "=B2", "=C2+10")) ' Horizontal vector, partially empty
3027 ''' oDoc.SetFormula("A1:D2", "=E1") ' D2 contains the formula "=H2"
3029 Dim sSet As String ' Return value.XSpreadsheet.Name)
3030 Dim oAddress As Object ' Alias of TargetRange
3031 Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property
3035 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
3036 sSet = ""
3038 Check:
3039 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
3040 If Not _IsStillAlive() Then GoTo Finally
3041 If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally
3042 If IsArray(Formula) Then
3043 If Not ScriptForge.SF_Utils._ValidateArray(Formula, "Formula", 0, V_STRING) Then GoTo Finally
3044 Else
3045 If Not ScriptForge.SF_Utils._Validate(Formula, "Formula", V_STRING) Then GoTo Finally
3046 End If
3047 End If
3049 Try:
3050 If VarType(TargetRange) = V_STRING Then Set oAddress = _ParseAddress(TargetRange) Else Set oAddress = TargetRange
3051 With oAddress
3052 If IsArray(Formula) Then
3053 ' Convert to data array and limit its size to the size of the initial range
3054 vDataArray = ScriptForge.SF_Array.ConvertToDataArray(Formula, Rows := .Height, Columns := .Width)
3055 If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally
3056 .XCellRange.setFormulaArray(vDataArray)
3057 Else
3058 With .XCellRange
3059 ' Store formula in top-left cell and paste it along the whole range
3061 .fillSeries(com.sun.star.sheet.FillDirection.TO_BOTTOM, com.sun.star.sheet.FillMode.SIMPLE, 0, 0, 0)
3062 .fillSeries(com.sun.star.sheet.FillDirection.TO_RIGHT, com.sun.star.sheet.FillMode.SIMPLE, 0, 0, 0)
3063 End With
3064 End If
3065 sSet = .RangeName
3066 End With
3068 Finally:
3069 SetFormula = sSet
3070 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
3071 Exit Function
3072 Catch:
3073 GoTo Finally
3074 End Function ' SFDocuments.SF_Calc.SetFormula
3076 REM -----------------------------------------------------------------------------
3077 Private Function SetProperty(Optional ByVal psProperty As String _
3078 , Optional ByVal pvValue As Variant _
3079 ) As Boolean
3080 ''' Set the new value of the named property
3081 ''' Args:
3082 ''' psProperty: the name of the property
3083 ''' pvValue: the new value of the given property
3084 ''' Returns:
3085 ''' True if successful
3087 Dim bSet As Boolean ' Return value
3088 Static oSession As Object ' Alias of SF_Session
3089 Dim cstThisSub As String
3092 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
3093 bSet = False
3096 If IsMissing(pvValue) Then pvValue = Empty
3097 'ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Validation done in Property Lets
3099 If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session")
3100 bSet = True
3101 Select Case UCase(psProperty)
3103 CurrentSelection = pvValue
3105 CustomProperties = pvValue
3107 Description = pvValue
3109 Keywords = pvValue
3111 Subject = pvValue
3113 Title = pvValue
3114 Case Else
3115 bSet = False
3116 End Select
3118 Finally:
3119 SetProperty = bSet
3120 'ScriptForge.SF_Utils._ExitFunction(cstThisSub)
3121 Exit Function
3122 Catch:
3123 GoTo Finally
3124 End Function ' SFDocuments.SF_Calc.SetProperty
3126 REM -----------------------------------------------------------------------------
3127 Public Function SetValue(Optional ByVal TargetRange As Variant _
3128 , Optional ByRef Value As Variant _
3129 ) As String
3130 ''' Set the given value in the given range
3131 ''' The full range is updated and the remainder of the sheet is left untouched
3132 ''' If the size of Value < the size of Range, then the other cells are emptied
3133 ''' If the size of Value > the size of Range, then Value is only partially copied
3134 ''' Vectors are always expanded vertically, except if the range has a height of exactly 1 row
3135 ''' Args:
3136 ''' TargetRange : the range as a string that should receive a new value
3137 ''' Value: a scalar, a vector or an array with the new values for each cell of the range.
3138 ''' The new values should be strings, numeric values or dates. Other types empty the corresponding cell
3139 ''' Returns:
3140 ''' A string representing the updated range
3141 ''' Examples:
3143 ''' oDoc.SetValue("A1:F1", Array(1, 2, 3)) ' Horizontal vector, partially empty
3144 ''' oDoc.SetValue("A1:D2", SF_Array.AppendRow(Array(1, 2, 3, 4), Array(5, 6, 7, 8)))
3146 Dim sSet As String ' Return value
3147 Dim oAddress As Object ' Alias of TargetRange
3148 Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property
3152 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
3153 sSet = ""
3155 Check:
3156 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
3157 If Not _IsStillAlive() Then GoTo Finally
3158 If Not ScriptForge.SF_Utils._Validate(TargetRange, "TargetRange", V_STRING) Then GoTo Finally
3159 If IsArray(Value) Then
3161 Else
3163 End If
3164 End If
3166 Try:
3167 Set oAddress = _ParseAddress(TargetRange)
3168 With oAddress
3169 ' Convert to data array and limit its size to the size of the initial range
3170 vDataArray = ScriptForge.SF_Array.ConvertToDataArray(Value, IsRange := True, Rows := .Height, Columns := .Width)
3171 If UBound(vDataArray) < LBound(vDataArray) Then GoTo Finally
3172 .XCellRange.setDataArray(vDataArray)
3173 sSet = .RangeName
3174 End With
3176 Finally:
3177 SetValue = sSet
3178 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
3179 Exit Function
3180 Catch:
3181 GoTo Finally
3182 End Function ' SFDocuments.SF_Calc.SetValue
3184 REM -----------------------------------------------------------------------------
3185 Public Function ShiftDown(Optional ByVal Range As Variant _
3186 , Optional ByVal WholeRow As Variant _
3187 , Optional ByVal Rows As Variant _
3188 ) As String
3189 ''' Move a specified range and all cells below in the same columns downwards by inserting empty cells
3190 ''' The inserted cells can span whole rows or be limited to the width of the range
3191 ''' The height of the inserted area is provided by the Rows argument
3192 ''' Nothing happens if the range shift crosses one of the edges of the worksheet
3193 ''' The execution of the method has no effect on the current selection
3194 ''' Args:
3195 ''' Range: the range above which cells have to be inserted, as a string
3196 ''' WholeRow: when True (default = False), insert whole rows
3197 ''' Rows: the height of the area to insert. Default = the height of the Range argument
3198 ''' Returns:
3199 ''' A string representing the new location of the initial range
3200 ''' Examples:
3201 ''' newrange = oDoc.ShiftDown("SheetX.A1:F10") ' "$SheetX.$A$11:$F$20"
3202 ''' newrange = oDoc.ShiftDown("SheetX.A1:F10", Rows := 3) ' "$SheetX.$A$4:$F$13"
3204 Dim sShift As String ' Return value
3205 Dim oSourceAddress As Object ' Alias of Range as _Address
3206 Dim lHeight As Long ' Range height
3207 Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width
3208 Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellInsertMode enum values
3213 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
3214 sShift = ""
3216 Check:
3217 If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False
3218 If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0
3219 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
3220 If Not _IsStillAlive(True) Then GoTo Finally
3222 If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally
3223 If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally
3224 End If
3226 Try:
3227 Set oSourceAddress = _ParseAddress(Range)
3229 With oSourceAddress
3231 ' Manage the height of the area to shift
3232 ' The insertCells() method inserts a number of rows equal to the height of the cell range to shift
3233 lHeight = .Height
3236 If Rows <> lHeight Then
3238 Else
3239 Set oShiftAddress = .XCellRange.RangeAddress
3240 End If
3242 ' Determine the shift mode
3243 With com.sun.star.sheet.CellInsertMode
3244 If WholeRow Then lShiftMode = .ROWS Else lShiftMode = .DOWN
3245 End With
3247 ' Move the cells as requested. This modifies .XCellRange
3248 .XSpreadsheet.insertCells(oShiftAddress, lShiftMode)
3250 ' Determine the receiving area
3251 sShift = .XCellRange.AbsoluteName
3253 End With
3255 Finally:
3256 ShiftDown = sShift
3257 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
3258 Exit Function
3259 Catch:
3260 ' When error, return the original range
3261 If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName
3262 GoTo Finally
3263 End Function ' SFDocuments.SF_Calc.ShiftDown
3265 REM -----------------------------------------------------------------------------
3266 Public Function ShiftLeft(Optional ByVal Range As Variant _
3267 , Optional ByVal WholeColumn As Variant _
3268 , Optional ByVal Columns As Variant _
3269 ) As String
3270 ''' Delete the leftmost columns of a specified range and move all cells at their right leftwards
3271 ''' The deleted cells can span whole columns or be limited to the height of the range
3272 ''' The width of the deleted area is provided by the Columns argument
3273 ''' The execution of the method has no effect on the current selection
3274 ''' Args:
3275 ''' Range: the range in which cells have to be erased, as a string
3276 ''' WholeColumn: when True (default = False), erase whole columns
3277 ''' Columns: the width of the area to delete.
3278 ''' Default = the width of the Range argument, it is also its maximum value
3279 ''' Returns:
3280 ''' A string representing the location of the remaining part of the initial range,
3281 ''' or the zero-length string if the whole range has been deleted
3282 ''' Examples:
3283 ''' newrange = oDoc.ShiftLeft("SheetX.G1:L10") ' """
3284 ''' newrange = oDoc.ShiftLeft("SheetX.G1:L10", Columns := 3) ' "$SheetX.$G$1:$I$10"
3286 Dim sShift As String ' Return value
3287 Dim oSourceAddress As Object ' Alias of Range as _Address
3288 Dim lWidth As Long ' Range width
3289 Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width
3290 Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellDeleteMode enum values
3295 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
3296 sShift = ""
3298 Check:
3299 If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False
3300 If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0
3301 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
3302 If Not _IsStillAlive(True) Then GoTo Finally
3304 If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally
3305 If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally
3306 End If
3308 Try:
3309 Set oSourceAddress = _ParseAddress(Range)
3310 Set _LastParsedAddress = Nothing ' Range will be erased. Force re-parsing next time
3312 With oSourceAddress
3314 ' Manage the width of the area to delete
3315 ' The removeRange() method erases a number of columns equal to the width of the cell range to delete
3316 lWidth = .Width
3318 If Columns < lWidth Then
3320 Else ' Columns is capped at the range width
3321 Set oShiftAddress = .XCellRange.RangeAddress
3322 End If
3324 ' Determine the Delete mode
3325 With com.sun.star.sheet.CellDeleteMode
3326 If WholeColumn Then lShiftMode = .COLUMNS Else lShiftMode = .LEFT
3327 End With
3329 ' Move the cells as requested. This modifies .XCellRange
3330 .XSpreadsheet.removeRange(oShiftAddress, lShiftMode)
3332 ' Determine the remaining area
3333 If Columns < lWidth Then sShift = .XCellRange.AbsoluteName
3335 End With
3337 Finally:
3338 ShiftLeft = sShift
3339 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
3340 Exit Function
3341 Catch:
3342 ' When error, return the original range
3343 If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName
3344 GoTo Finally
3345 End Function ' SFDocuments.SF_Calc.ShiftLeft
3347 REM -----------------------------------------------------------------------------
3348 Public Function ShiftRight(Optional ByVal Range As Variant _
3349 , Optional ByVal WholeColumn As Variant _
3350 , Optional ByVal Columns As Variant _
3351 ) As String
3352 ''' Move a specified range and all next cells in the same rows to the right by inserting empty cells
3353 ''' The inserted cells can span whole columns or be limited to the height of the range
3354 ''' The width of the inserted area is provided by the Columns argument
3355 ''' Nothing happens if the range shift crosses one of the edges of the worksheet
3356 ''' The execution of the method has no effect on the current selection
3357 ''' Args:
3358 ''' Range: the range before which cells have to be inserted, as a string
3359 ''' WholeColumn: when True (default = False), insert whole columns
3360 ''' Columns: the width of the area to insert. Default = the width of the Range argument
3361 ''' Returns:
3362 ''' A string representing the new location of the initial range
3363 ''' Examples:
3364 ''' newrange = oDoc.ShiftRight("SheetX.A1:F10") ' "$SheetX.$G$1:$L$10"
3365 ''' newrange = oDoc.ShiftRight("SheetX.A1:F10", Columns := 3) ' "$SheetX.$D$1:$I$10"
3367 Dim sShift As String ' Return value
3368 Dim oSourceAddress As Object ' Alias of Range as _Address
3369 Dim lWidth As Long ' Range width
3370 Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right width
3371 Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellInsertMode enum values
3376 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
3377 sShift = ""
3379 Check:
3380 If IsMissing(WholeColumn) Or IsEmpty(WholeColumn) Then WholeColumn = False
3381 If IsMissing(Columns) Or IsEmpty(Columns) Then Columns = 0
3382 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
3383 If Not _IsStillAlive(True) Then GoTo Finally
3385 If Not ScriptForge.SF_Utils._Validate(WholeColumn, "WholeColumn", ScriptForge.V_BOOLEAN) Then GoTo Finally
3386 If Not ScriptForge.SF_Utils._Validate(Columns, "Columns", ScriptForge.V_NUMERIC) Then GoTo Finally
3387 End If
3389 Try:
3390 Set oSourceAddress = _ParseAddress(Range)
3392 With oSourceAddress
3394 ' Manage the width of the area to Shift
3395 ' The insertCells() method inserts a number of columns equal to the width of the cell range to Shift
3396 lWidth = .Width
3399 If Columns <> lWidth Then
3401 Else
3402 Set oShiftAddress = .XCellRange.RangeAddress
3403 End If
3405 ' Determine the Shift mode
3406 With com.sun.star.sheet.CellInsertMode
3407 If WholeColumn Then lShiftMode = .COLUMNS Else lShiftMode = .RIGHT
3408 End With
3410 ' Move the cells as requested. This modifies .XCellRange
3411 .XSpreadsheet.insertCells(oShiftAddress, lShiftMode)
3413 ' Determine the receiving area
3414 sShift = .XCellRange.AbsoluteName
3416 End With
3418 Finally:
3419 ShiftRight = sShift
3420 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
3421 Exit Function
3422 Catch:
3423 ' When error, return the original range
3424 If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName
3425 GoTo Finally
3426 End Function ' SFDocuments.SF_Calc.ShiftRight
3428 REM -----------------------------------------------------------------------------
3429 Public Function ShiftUp(Optional ByVal Range As Variant _
3430 , Optional ByVal WholeRow As Variant _
3431 , Optional ByVal Rows As Variant _
3432 ) As String
3433 ''' Delete the topmost rows of a specified range and move all cells below upwards
3434 ''' The deleted cells can span whole rows or be limited to the width of the range
3435 ''' The height of the deleted area is provided by the Rows argument
3436 ''' The execution of the method has no effect on the current selection
3437 ''' Args:
3438 ''' Range: the range in which cells have to be erased, as a string
3439 ''' WholeRow: when True (default = False), erase whole rows
3440 ''' Rows: the height of the area to delete.
3441 ''' Default = the height of the Range argument, it is also its maximum value
3442 ''' Returns:
3443 ''' A string representing the location of the remaining part of the initial range,
3444 ''' or the zero-length string if the whole range has been deleted
3445 ''' Examples:
3447 ''' newrange = oDoc.ShiftUp("SheetX.G1:L10", Rows := 3) ' "$SheetX.$G$1:$I$10"
3449 Dim sShift As String ' Return value
3450 Dim oSourceAddress As Object ' Alias of Range as _Address
3451 Dim lHeight As Long ' Range height
3452 Dim oShiftAddress As Object ' com.sun.star.table.CellRangeAddress - Range adjusted to the right height
3453 Dim lShiftMode As Long ' One of the com.sun.star.sheet.CellDeleteMode enum values
3458 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
3459 sShift = ""
3461 Check:
3462 If IsMissing(WholeRow) Or IsEmpty(WholeRow) Then WholeRow = False
3463 If IsMissing(Rows) Or IsEmpty(Rows) Then Rows = 0
3464 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
3465 If Not _IsStillAlive(True) Then GoTo Finally
3467 If Not ScriptForge.SF_Utils._Validate(WholeRow, "WholeRow", ScriptForge.V_BOOLEAN) Then GoTo Finally
3468 If Not ScriptForge.SF_Utils._Validate(Rows, "Rows", ScriptForge.V_NUMERIC) Then GoTo Finally
3469 End If
3471 Try:
3472 Set oSourceAddress = _ParseAddress(Range)
3473 Set _LastParsedAddress = Nothing ' Range will be erased. Force re-parsing next time
3475 With oSourceAddress
3477 ' Manage the height of the area to delete
3478 ' The removeRange() method erases a number of rows equal to the height of the cell range to delete
3479 lHeight = .Height
3481 If Rows < lHeight Then
3483 Else ' Rows is capped at the range height
3484 Set oShiftAddress = .XCellRange.RangeAddress
3485 End If
3487 ' Determine the Delete mode
3488 With com.sun.star.sheet.CellDeleteMode
3489 If WholeRow Then lShiftMode = .ROWS Else lShiftMode = .UP
3490 End With
3492 ' Move the cells as requested. This modifies .XCellRange
3493 .XSpreadsheet.removeRange(oShiftAddress, lShiftMode)
3495 ' Determine the remaining area
3496 If Rows < lHeight Then sShift = .XCellRange.AbsoluteName
3498 End With
3500 Finally:
3501 ShiftUp = sShift
3502 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
3503 Exit Function
3504 Catch:
3505 ' When error, return the original range
3506 If Not IsNull(oSourceAddress) Then sShift = oSourceAddress.RangeName
3507 GoTo Finally
3508 End Function ' SFDocuments.SF_Calc.ShiftUp
3510 REM -----------------------------------------------------------------------------
3511 Public Function SortRange(Optional ByVal Range As Variant _
3512 , Optional ByVal SortKeys As Variant _
3513 , Optional ByVal SortOrder As Variant _
3514 , Optional ByVal DestinationCell As Variant _
3515 , Optional ByVal ContainsHeader As Variant _
3516 , Optional ByVal CaseSensitive As Variant _
3517 , Optional ByVal SortColumns As Variant _
3518 ) As Variant
3519 ''' Sort the given range on any number of columns/rows. The sorting order may vary by column/row
3520 ''' If the number of sort keys is > 3 then the range is sorted several times, by groups of 3 keys,
3521 ''' starting from the last key. In this context the algorithm used by Calc to sort ranges
3522 ''' is presumed STABLE, i.e. it maintains the relative order of records with equal keys.
3523 '''
3524 ''' Args:
3525 ''' Range: the range to sort as a string
3526 ''' SortKeys: a scalar (if 1 column/row) or an array of column/row numbers starting from 1
3527 ''' SortOrder: a scalar or an array of strings: "ASC" or "DESC"
3528 ''' Each item is paired with the corresponding item in SortKeys
3529 ''' If the SortOrder array is shorter than SortKeys, the remaining keys are sorted
3530 ''' in ascending order
3531 ''' DestinationCell: the destination of the sorted range of cells, as a string
3532 ''' If given as range, the destination will be reduced to its top-left cell
3533 ''' By default, Range is overwritten with its sorted content
3534 ''' ContainsHeader: when True, the first row/column is not sorted. Default = False
3535 ''' CaseSensitive: only for string comparisons, default = False
3536 ''' SortColumns: when True, the columns are sorted from left to right
3537 ''' Default = False: rows are sorted from top to bottom.
3538 ''' Returns:
3539 ''' The modified range of cells as a string
3540 ''' Example:
3541 ''' oDoc.SortRange("A2:J200", Array(1, 3), , Array("ASC", "DESC"), CaseSensitive := True)
3542 ''' ' Sort on columns A (ascending) and C (descending)
3544 Dim sSort As String ' Return value
3545 Dim oRangeAddress As _Address ' Parsed range
3546 Dim oRange As Object ' com.sun.star.table.XCellRange
3547 Dim oSortRange As Object ' The area to sort as an _Address object
3548 Dim oDestRange As Object ' Destination as a range
3549 Dim oDestAddress As Object ' com.sun.star.table.CellRangeAddress
3550 Dim oDestCell As Object ' com.sun.star.table.CellAddress
3551 Dim vSortDescriptor As Variant ' Array of com.sun.star.beans.PropertyValue
3552 Dim vSortFields As Variant ' Array of com.sun.star.table.TableSortField
3553 Dim sOrder As String ' Item in SortOrder
3554 Dim lSort As Long ' Counter for sub-sorts
3555 Dim lKeys As Long ' UBound of SortKeys
3556 Dim lKey As Long ' Actual index in SortKeys
3557 Dim i As Long, j As Long
3561 Const cstSubArgs = "Range, SortKeys, [TargetRange=""""], [SortOrder=""ASC""], [DestinationCell=""""], [ContainsHeader=False], [CaseSensitive=False], [SortColumns=False]"
3563 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
3564 sSort = ""
3566 Check:
3567 If IsMissing(SortKeys) Or IsEmpty(SortKeys) Then
3568 SortKeys = Array(1)
3569 ElseIf Not IsArray(SortKeys) Then
3570 SortKeys = Array(SortKeys)
3571 End If
3572 If IsMissing(DestinationCell) Or IsEmpty(DestinationCell) Then DestinationCell = ""
3573 If IsMissing(SortOrder) Or IsEmpty(SortOrder) Then
3575 ElseIf Not IsArray(SortOrder) Then
3576 SortOrder = Array(SortOrder)
3577 End If
3578 If IsMissing(ContainsHeader) Or IsEmpty(ContainsHeader) Then ContainsHeader = False
3579 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
3580 If IsMissing(SortColumns) Or IsEmpty(SortColumns) Then SortColumns = False
3581 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
3582 If Not _IsStillAlive() Then GoTo Finally
3584 If Not ScriptForge.SF_Utils._ValidateArray(SortKeys, "SortKeys", 1, V_NUMERIC, True) Then GoTo Finally
3585 If Not ScriptForge.SF_Utils._Validate(DestinationCell, "DestinationCell", V_STRING) Then GoTo Finally
3586 If Not ScriptForge.SF_Utils._ValidateArray(SortOrder, "SortOrder", 1, V_STRING, True) Then GoTo Finally
3587 If Not ScriptForge.SF_Utils._Validate(ContainsHeader, "ContainsHeader", ScriptForge.V_BOOLEAN) Then GoTo Finally
3588 If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", ScriptForge.V_BOOLEAN) Then GoTo Finally
3589 If Not ScriptForge.SF_Utils._Validate(SortColumns, "SortColumns", ScriptForge.V_BOOLEAN) Then GoTo Finally
3590 End If
3591 Set oRangeAddress = _ParseAddress(Range)
3592 If Len(DestinationCell) > 0 Then Set oDestRange = _ParseAddress(DestinationCell) Else Set oDestRange = Nothing
3594 Try:
3595 ' Initialize a generic sort descriptor
3596 Set oRange = oRangeAddress.XCellRange
3597 vSortDescriptor = oRange.createSortDescriptor ' Makes a generic sort descriptor for ranges
3598 vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsSortColumns", SortColumns)
3599 vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "ContainsHeader", ContainsHeader)
3600 vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "BindFormatsToContent", True)
3601 vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "IsUserListEnabled", False)
3603 ' Sort by keys group
3605 lKeys = UBound(SortKeys)
3606 lSort = Int(lKeys / cstMaxKeys)
3607 Set oSortRange = oRangeAddress
3611 ' The 1st sort must consider the destination area. Next sorts are done on the destination area
3613 vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", False)
3614 vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "OutputPosition", Nothing)
3615 Else
3616 Set oDestAddress = oDestRange.XCellRange.RangeAddress
3617 Set oDestCell = New com.sun.star.table.CellAddress
3618 With oDestAddress
3619 oDestCell.Sheet = .Sheet
3620 oDestCell.Column = .StartColumn
3621 oDestCell.Row = .StartRow
3622 End With
3623 vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "CopyOutputData", True)
3624 vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "OutputPosition", oDestCell)
3625 End If
3627 ' Define the sorting keys
3628 vSortFields = DimArray(lKeys Mod cstMaxKeys)
3629 For i = 0 To UBound(vSortFields)
3630 vSortFields(i) = New com.sun.star.table.TableSortField
3631 lKey = j * cstMaxKeys + i
3634 With vSortFields(i)
3635 .Field = SortKeys(lKey) - 1
3637 .IsCaseSensitive = CaseSensitive
3638 End With
3639 Next i
3640 lKeys = lKeys - UBound(vSortFields) - 1
3642 ' Associate the keys and the descriptor, and sort
3643 vSortDescriptor = ScriptForge.SF_Utils._SetPropertyValue(vSortDescriptor, "SortFields", vSortFields)
3644 oSortRange.XCellRange.sort(vSortDescriptor)
3646 ' Next loop, if any, is done on the destination area
3647 If Len(DestinationCell) > 0 And j = lSort And lSort > 0 Then Set oSortRange = _Offset(oDestRange, 0, 0, oRangeAddress.Height, oRangeAddress.Width)
3649 Next j
3651 ' Compute the changed area
3652 If Len(DestinationCell) = 0 Then
3653 sSort = oRangeAddress.RangeName
3654 Else
3655 With oRangeAddress
3657 End With
3658 End If
3660 Finally:
3661 SortRange = sSort
3662 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
3663 Exit Function
3664 Catch:
3665 GoTo Finally
3666 End Function ' SFDocuments.SF_Calc.SortRange
3668 REM ======================================================= SUPERCLASS PROPERTIES
3670 REM -----------------------------------------------------------------------------
3671 Property Get CustomProperties() As Variant
3673 End Property ' SFDocuments.SF_Calc.CustomProperties
3675 REM -----------------------------------------------------------------------------
3676 Property Let CustomProperties(Optional ByVal pvCustomProperties As Variant)
3677 [_Super].CustomProperties = pvCustomProperties
3678 End Property ' SFDocuments.SF_Calc.CustomProperties
3680 REM -----------------------------------------------------------------------------
3681 Property Get Description() As Variant
3683 End Property ' SFDocuments.SF_Calc.Description
3685 REM -----------------------------------------------------------------------------
3686 Property Let Description(Optional ByVal pvDescription As Variant)
3687 [_Super].Description = pvDescription
3688 End Property ' SFDocuments.SF_Calc.Description
3690 REM -----------------------------------------------------------------------------
3691 Property Get DocumentProperties() As Variant
3693 End Property ' SFDocuments.SF_Calc.DocumentProperties
3695 REM -----------------------------------------------------------------------------
3696 Property Get DocumentType() As String
3698 End Property ' SFDocuments.SF_Calc.DocumentType
3700 REM -----------------------------------------------------------------------------
3701 Property Get ExportFilters() As Variant
3703 End Property ' SFDocuments.SF_Calc.ExportFilters
3705 REM -----------------------------------------------------------------------------
3706 Property Get FileSystem() As String
3708 End Property ' SFDocuments.SF_Calc.FileSystem
3710 REM -----------------------------------------------------------------------------
3711 Property Get ImportFilters() As Variant
3713 End Property ' SFDocuments.SF_Calc.ImportFilters
3715 REM -----------------------------------------------------------------------------
3716 Property Get IsAlive() As Boolean
3718 End Property ' SFDocuments.SF_Calc.IsAlive
3720 REM -----------------------------------------------------------------------------
3721 Property Get IsBase() As Boolean
3723 End Property ' SFDocuments.SF_Calc.IsBase
3725 REM -----------------------------------------------------------------------------
3726 Property Get IsCalc() As Boolean
3728 End Property ' SFDocuments.SF_Calc.IsCalc
3730 REM -----------------------------------------------------------------------------
3731 Property Get IsDraw() As Boolean
3733 End Property ' SFDocuments.SF_Calc.IsDraw
3735 REM -----------------------------------------------------------------------------
3736 Property Get IsFormDocument() As Boolean
3738 End Property ' SFDocuments.SF_Writer.IsFormDocument
3740 REM -----------------------------------------------------------------------------
3741 Property Get IsImpress() As Boolean
3743 End Property ' SFDocuments.SF_Calc.IsImpress
3745 REM -----------------------------------------------------------------------------
3746 Property Get IsMath() As Boolean
3748 End Property ' SFDocuments.SF_Calc.IsMath
3750 REM -----------------------------------------------------------------------------
3751 Property Get IsWriter() As Boolean
3753 End Property ' SFDocuments.SF_Calc.IsWriter
3755 REM -----------------------------------------------------------------------------
3756 Property Get Keywords() As Variant
3758 End Property ' SFDocuments.SF_Calc.Keywords
3760 REM -----------------------------------------------------------------------------
3761 Property Let Keywords(Optional ByVal pvKeywords As Variant)
3762 [_Super].Keywords = pvKeywords
3763 End Property ' SFDocuments.SF_Calc.Keywords
3765 REM -----------------------------------------------------------------------------
3766 Property Get Readonly() As Variant
3768 End Property ' SFDocuments.SF_Calc.Readonly
3770 REM -----------------------------------------------------------------------------
3771 Property Get StyleFamilies() As Variant
3773 End Property ' SFDocuments.SF_Calc.StyleFamilies
3775 REM -----------------------------------------------------------------------------
3776 Property Get Subject() As Variant
3778 End Property ' SFDocuments.SF_Calc.Subject
3780 REM -----------------------------------------------------------------------------
3781 Property Let Subject(Optional ByVal pvSubject As Variant)
3782 [_Super].Subject = pvSubject
3783 End Property ' SFDocuments.SF_Calc.Subject
3785 REM -----------------------------------------------------------------------------
3786 Property Get Title() As Variant
3788 End Property ' SFDocuments.SF_Calc.Title
3790 REM -----------------------------------------------------------------------------
3791 Property Let Title(Optional ByVal pvTitle As Variant)
3792 [_Super].Title = pvTitle
3793 End Property ' SFDocuments.SF_Calc.Title
3795 REM -----------------------------------------------------------------------------
3796 Property Get XComponent() As Variant
3798 End Property ' SFDocuments.SF_Calc.XComponent
3800 REM -----------------------------------------------------------------------------
3801 Property Get XDocumentSettings() As Variant
3803 End Property ' SFDocuments.SF_Calc.XDocumentSettings
3805 REM ========================================================== SUPERCLASS METHODS
3807 REM -----------------------------------------------------------------------------
3808 'Public Function Activate() As Boolean
3809 ' Activate = [_Super].Activate()
3812 REM -----------------------------------------------------------------------------
3813 Public Function CloseDocument(Optional ByVal SaveAsk As Variant) As Boolean
3814 CloseDocument = [_Super].CloseDocument(SaveAsk)
3815 End Function ' SFDocuments.SF_Calc.CloseDocument
3817 REM -----------------------------------------------------------------------------
3818 Public Function ContextMenus(Optional ByVal ContextMenuName As Variant _
3819 , Optional ByVal SubmenuChar As Variant _
3820 ) As Variant
3821 ContextMenus = [_Super].ContextMenus(ContextMenuName, SubmenuChar)
3822 End Function ' SFDocuments.SF_Calc.ContextMenus
3824 REM -----------------------------------------------------------------------------
3825 Public Function CreateMenu(Optional ByVal MenuHeader As Variant _
3826 , Optional ByVal Before As Variant _
3827 , Optional ByVal SubmenuChar As Variant _
3828 ) As Object
3829 Set CreateMenu = [_Super].CreateMenu(MenuHeader, Before, SubmenuChar)
3830 End Function ' SFDocuments.SF_Calc.CreateMenu
3832 REM -----------------------------------------------------------------------------
3833 Public Sub DeleteStyles(Optional ByVal Family As Variant _
3834 , Optional ByRef StylesList As Variant _
3835 )
3836 [_Super].DeleteStyles(Family, StylesList)
3837 End Sub ' SFDocuments.SF_Calc.DeleteStyles
3839 REM -----------------------------------------------------------------------------
3840 Public Sub Echo(Optional ByVal EchoOn As Variant _
3841 , Optional ByVal Hourglass As Variant _
3842 )
3843 [_Super].Echo(EchoOn, Hourglass)
3844 End Sub ' SFDocuments.SF_Calc.Echo
3846 REM -----------------------------------------------------------------------------
3847 Public Function ExportAsPDF(Optional ByVal FileName As Variant _
3848 , Optional ByVal Overwrite As Variant _
3849 , Optional ByVal Pages As Variant _
3850 , Optional ByVal Password As Variant _
3851 , Optional ByVal Watermark As Variant _
3852 ) As Boolean
3853 ExportAsPDF = [_Super].ExportAsPDF(FileName, Overwrite, Pages, Password, Watermark)
3854 End Function ' SFDocuments.SF_Calc.ExportAsPDF
3856 REM -----------------------------------------------------------------------------
3857 Public Sub ImportStylesFromFile(Optional FileName As Variant _
3858 , Optional ByRef Families As Variant _
3859 , Optional ByVal Overwrite As variant _
3860 ) As Variant
3861 [_Super]._ImportStylesFromFile(FileName, Families, Overwrite)
3862 End Sub ' SFDocuments.SF_Calc.ImportStylesFromFile
3864 REM -----------------------------------------------------------------------------
3865 Public Function RemoveMenu(Optional ByVal MenuHeader As Variant) As Boolean
3866 RemoveMenu = [_Super].RemoveMenu(MenuHeader)
3867 End Function ' SFDocuments.SF_Calc.RemoveMenu
3869 REM -----------------------------------------------------------------------------
3870 Public Sub RunCommand(Optional ByVal Command As Variant _
3871 , ParamArray Args As Variant _
3872 )
3873 [_Super].RunCommand(Command, Args)
3874 End Sub ' SFDocuments.SF_Calc.RunCommand
3876 REM -----------------------------------------------------------------------------
3877 Public Function Save() As Boolean
3878 Save = [_Super].Save()
3879 End Function ' SFDocuments.SF_Calc.Save
3881 REM -----------------------------------------------------------------------------
3882 Public Function SaveAs(Optional ByVal FileName As Variant _
3883 , Optional ByVal Overwrite As Variant _
3884 , Optional ByVal Password As Variant _
3885 , Optional ByVal FilterName As Variant _
3886 , Optional ByVal FilterOptions As Variant _
3887 ) As Boolean
3888 SaveAs = [_Super].SaveAs(FileName, Overwrite, Password, FilterName, FilterOptions)
3889 End Function ' SFDocuments.SF_Calc.SaveAs
3891 REM -----------------------------------------------------------------------------
3892 Public Function SaveCopyAs(Optional ByVal FileName As Variant _
3893 , Optional ByVal Overwrite As Variant _
3894 , Optional ByVal Password As Variant _
3895 , Optional ByVal FilterName As Variant _
3896 , Optional ByVal FilterOptions As Variant _
3897 ) As Boolean
3898 SaveCopyAs = [_Super].SaveCopyAs(FileName, Overwrite, Password, FilterName, FilterOptions)
3899 End Function ' SFDocuments.SF_Calc.SaveCopyAs
3901 REM -----------------------------------------------------------------------------
3902 Public Function SetPrinter(Optional ByVal Printer As Variant _
3903 , Optional ByVal Orientation As Variant _
3904 , Optional ByVal PaperFormat As Variant _
3905 ) As Boolean
3906 SetPrinter = [_Super].SetPrinter(Printer, Orientation, PaperFormat)
3907 End Function ' SFDocuments.SF_Calc.SetPrinter
3909 REM -----------------------------------------------------------------------------
3910 Public Function Styles(Optional ByVal Family As Variant _
3911 , Optional ByVal NamePattern As variant _
3912 , Optional ByVal Used As variant _
3913 , Optional ByVal UserDefined As Variant _
3914 , Optional ByVal ParentStyle As Variant _
3915 , Optional ByVal Category As Variant _
3916 ) As Variant
3917 Styles = [_Super].Styles(Family, NamePattern, Used, UserDefined, ParentStyle, Category)
3918 End Function ' SFDocuments.SF_Calc.Styles
3920 REM -----------------------------------------------------------------------------
3921 Public Function Toolbars(Optional ByVal ToolbarName As Variant) As Variant
3922 Toolbars = [_Super].Toolbars(ToolbarName)
3923 End Function ' SFDocuments.SF_Calc.Toolbars
3925 REM -----------------------------------------------------------------------------
3926 Public Function XStyle(Optional ByVal Family As Variant _
3927 , Optional ByVal StyleName As variant _
3928 ) As Object
3929 Set XStyle = [_Super].XStyle(Family, StyleName)
3930 End Function ' SFDocuments.SF_Calc.XStyle
3932 REM =========================================================== PRIVATE FUNCTIONS
3934 REM -----------------------------------------------------------------------------
3935 Private Sub _ClearRange(ByVal psTarget As String _
3936 , Optional ByVal Range As Variant _
3937 , Optional FilterFormula As Variant _
3938 , Optional FilterScope As Variant _
3939 )
3940 ''' Clear the given range with the given options
3941 ''' The range may be filtered by a formula for a selective clearance
3942 ''' Arguments checking is done in this Sub, not in the calling one
3943 ''' Args:
3945 ''' Range: the range to clear as a string
3946 ''' FilterFormula: a selection of cells based on a Calc formula
3947 ''' When left empty, all the cells of the range are cleared
3950 Dim lClear As Long ' A combination of com.sun.star.sheet.CellFlags
3951 Dim oRange As Object ' Alias of Range
3952 Dim vRanges() As Variant ' Array of subranges resulting from the application of the filter
3953 Dim i As Long
3956 Const cstSubArgs = "Range, [FilterFormula=""], [FilterScope=""CELL""|""ROW""|""COLUMN""]"
3958 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
3960 Check:
3961 If IsMissing(FilterFormula) Or IsEmpty(FilterFormula) Then FilterFormula = ""
3963 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
3964 If Not _IsStillAlive() Then GoTo Finally
3965 If Not ScriptForge.SF_Utils._Validate(Range, "Range", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally
3966 If Not ScriptForge.SF_Utils._Validate(FilterFormula, "FilterFormula", V_STRING) Then GoTo Finally
3968 If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING, Array("CELL", "ROW", "COLUMN")) Then GoTo Finally
3969 Else
3970 If Not ScriptForge.SF_Utils._Validate(FilterScope, "FilterScope", V_STRING) Then GoTo Finally
3971 End If
3972 End If
3974 Try:
3975 With com.sun.star.sheet.CellFlags
3976 Select Case psTarget
3978 lClear = .VALUE + .DATETIME + .STRING + .ANNOTATION + .FORMULA _
3979 + .HARDATTR + .STYLES + .OBJECTS + .EDITATTR + .FORMATTED
3981 lClear = .HARDATTR + .STYLES + .EDITATTR + .FORMATTED
3983 lClear = .VALUE + .DATETIME + .STRING + .FORMULA
3984 End Select
3985 End With
3987 If VarType(Range) = V_STRING Then Set oRange = _ParseAddress(Range) Else Set oRange = Range
3989 ' Without filter, the whole range is cleared
3990 ' Otherwise the filter cuts the range in subranges and clears them one by one
3991 If Len(FilterFormula) = 0 Then
3992 oRange.XCellRange.clearContents(lClear)
3993 Else
3994 vRanges() = _ComputeFilter(oRange, FilterFormula, UCase(FilterScope))
3995 For i = 0 To UBound(vRanges)
3996 vRanges(i).XCellRange.clearContents(lClear)
3997 Next i
3998 End If
4000 Finally:
4001 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
4002 Exit Sub
4003 Catch:
4004 GoTo Finally
4005 End Sub ' SFDocuments.SF_Calc._ClearRange
4007 REM -----------------------------------------------------------------------------
4008 Private Function _ComputeFilter(ByRef poRange As Object _
4009 , ByVal psFilterFormula As String _
4010 , ByVal psFilterScope As String _
4011 ) As Variant
4012 ''' Compute in the given range the cells, rows or columns for which
4013 ''' the given formula returns TRUE
4014 ''' Args:
4015 ''' poRange: the range on which to compute the filter as an _Address type
4016 ''' psFilterFormula: the formula to be applied on each row, column or cell
4018 ''' Returns:
4019 ''' An array of ranges as objects of type _Address
4021 Dim vRanges As Variant ' Return value
4022 Dim oRange As Object ' A single vRanges() item
4023 Dim lLast As Long ' Last used row or column number in the sheet containing Range
4024 Dim oFormulaRange As _Address ' Range where the FilterFormula must be stored
4025 Dim sFormulaDirection As String ' Either V(ertical), H(orizontal) or B(oth)
4026 Dim vDataArray As Variant ' DataArray compatible with .DataArray UNO property
4027 Dim vFilter As Variant ' Array of Boolean values indicating which rows should be erased
4028 Dim bFilter As Boolean ' A single item in vFilter
4029 Dim iDims As Integer ' Number of dimensions of vFilter()
4030 Dim lLower As Long ' Lower level of contiguous True filter values
4031 Dim lUpper As Long ' Upper level of contiguous True filter values
4032 Dim i As Long, j As Long
4034 Check:
4035 ' Error handling is determined by the calling method
4036 vRanges = Array()
4038 Try:
4039 With poRange
4041 ' Compute the range where to apply the formula
4042 ' Determine the direction of the range containing the formula vertical, horizontal or both
4043 Select Case psFilterScope
4045 lLast = LastColumn(.SheetName)
4046 ' Put formulas as a single column in the unused area at the right of the range to filter
4047 Set oFormulaRange = _Offset(poRange, 0, lLast - .XCellRange.RangeAddress.StartColumn + 1, 0, 1)
4050 lLast = LastRow(.SheetName)
4051 ' Put formulas as a single row in the unused area at the bottom of the range to filter
4055 lLast = LastRow(.SheetName)
4056 ' Put formulas as a matrix in the unused area at the bottom of the range to filter
4059 If oFormulaRange.Width = 1 Then
4061 ElseIf oFormulaRange.Height = 1 Then
4063 End If
4064 End Select
4066 ' Apply the formula and get the result as an array of Boolean values. Clean up
4067 SetFormula(oFormulaRange, psFilterFormula)
4068 vDataArray = oFormulaRange.XCellRange.getDataArray()
4069 vFilter = ScriptForge.SF_Array.ConvertFromDataArray(vDataArray)
4070 iDims = ScriptForge.SF_Array.CountDims(vFilter)
4071 ClearAll(oFormulaRange)
4074 Select Case iDims
4076 If vFilter = 1 Then vRanges = ScriptForge.SF_Array.Append(vRanges, poRange)
4078 ' Nothing to do
4080 ' Strategy: group contiguous applicable rows/columns to optimize heavy operations like CompactUp, CompactLeft
4081 ' Stack the contiguous ranges of True values in vRanges()
4083 ' To manage vector and array with same code, setup a single fictitious loop when vector, otherwise scan array by row
4087 For j = 0 To UBound(vFilter, iDims)
4088 If iDims = 1 Then bFilter = CBool(vFilter(j)) Else bFilter = CBool(vFilter(i, j))
4091 lUpper = j
4092 ElseIf Not bFilter Then
4094 ElseIf bFilter Then
4096 End If
4097 ' Determine the next applicable range when one found and limit reached
4103 Else ' CELL
4105 End If
4106 If Not IsNull(oRange) Then vRanges = ScriptForge.SF_Array.Append(vRanges, oRange)
4108 End If
4109 Next j
4111 Next i
4112 Case Else
4113 ' Should not happen
4114 End Select
4116 End With
4118 Finally:
4119 _ComputeFilter = vRanges()
4120 Exit Function
4121 End Function ' SFDocuments.SF_Calc._ComputeFilter
4123 REM -----------------------------------------------------------------------------
4124 Private Function _DFunction(ByVal psFunction As String _
4125 , Optional ByVal Range As Variant _
4126 ) As Double
4127 ''' Apply the given function on all the numeric values stored in the given range
4128 ''' Args:
4129 ''' Range : the range as a string where to apply the function on
4130 ''' Returns:
4131 ''' The resulting value as a double
4133 Dim dblGet As Double ' Return value
4134 Dim oAddress As Object ' Alias of Range
4135 Dim vFunction As Variant ' com.sun.star.sheet.GeneralFunction.XXX
4139 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
4140 dblGet = 0
4142 Check:
4143 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
4144 If Not _IsStillAlive() Then GoTo Finally
4146 End If
4148 Try:
4149 ' Get the data
4150 Set oAddress = _ParseAddress(Range)
4151 Select Case psFunction
4157 Case Else : GoTo Finally
4158 End Select
4159 dblGet = oAddress.XCellRange.computeFunction(vFunction)
4161 Finally:
4162 _DFunction = dblGet
4163 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
4164 Exit Function
4165 Catch:
4166 GoTo Finally
4167 End Function ' SFDocuments.SF_Calc._DFunction
4169 REM -----------------------------------------------------------------------------
4170 Private Function _FileIdent() As String
4171 ''' Returns a file identification from the information that is currently available
4172 ''' Useful e.g. for display in error messages
4174 _FileIdent = [_Super]._FileIdent()
4176 End Function ' SFDocuments.SF_Calc._FileIdent
4178 REM -----------------------------------------------------------------------------
4179 Function _GetColumnName(ByVal plColumnNumber As Long) As String
4180 ''' Convert a column number (range 1, 2,..16384) into its letter counterpart (range 'A', 'B',..'XFD').
4181 ''' Args:
4183 ''' Returns:
4184 ''' a string representation of the column name, in range 'A'..'XFD'
4185 ''' Adapted from a Python function by sundar nataraj
4186 ''' http://stackoverflow.com/questions/23861680/convert-spreadsheet-number-to-column-letter
4188 Dim sCol As String ' Return value
4189 Dim lDiv As Long ' Intermediate result
4192 Try:
4193 sCol = ""
4194 lDiv = plColumnNumber
4198 lDiv = (lDiv - lMod) \ 26
4199 Loop
4201 Finally:
4202 _GetColumnName = sCol
4203 End Function ' SFDocuments.SF_Calc._GetColumnName
4205 REM -----------------------------------------------------------------------------
4206 Private Function _IsStillAlive(Optional ByVal pbForUpdate As Boolean _
4207 , Optional ByVal pbError As Boolean _
4208 ) As Boolean
4209 ''' Returns True if the document has not been closed manually or incidentally since the last use
4210 ''' If dead the actual instance is disposed. The execution is cancelled when pbError = True (default)
4211 ''' Args:
4212 ''' pbForUpdate: if True (default = False), check additionally if document is open for editing
4213 ''' pbError: if True (default), raise a fatal error
4215 Dim bAlive As Boolean ' Return value
4217 If IsMissing(pbForUpdate) Then pbForUpdate = False
4218 If IsMissing(pbError) Then pbError = True
4220 Try:
4221 bAlive = [_Super]._IsStillAlive(pbForUpdate, pbError)
4223 Finally:
4224 _IsStillAlive = bAlive
4225 Exit Function
4226 End Function ' SFDocuments.SF_Calc._IsStillAlive
4228 REM -----------------------------------------------------------------------------
4229 Private Function _LastCell(ByRef poSheet As Object) As Variant
4230 ''' Returns in an array the coordinates of the last used cell in the given sheet
4232 Dim oCursor As Object ' Cursor on the cell
4233 Dim oRange As Object ' The used range
4236 Try:
4238 oCursor.gotoEndOfUsedArea(True)
4239 Set oRange = poSheet.getCellRangeByName(oCursor.AbsoluteName)
4244 Finally:
4245 _LastCell = vCoordinates
4246 End Function ' SFDocuments.SF_Calc._LastCell
4248 REM -----------------------------------------------------------------------------
4249 Public Function _Offset(ByRef pvRange As Variant _
4250 , ByVal plRows As Long _
4251 , ByVal plColumns As Long _
4252 , ByVal plHeight As Long _
4253 , ByVal plWidth As Long _
4254 ) As Object
4255 ''' Returns a new range offset by a certain number of rows and columns from a given range
4256 ''' Args:
4257 ''' pvRange : the range, as a string or an object, from which the function searches for the new range
4258 ''' plRows : the number of rows by which the reference was corrected up (negative value) or down.
4259 ''' plColumns : the number of columns by which the reference was corrected to the left (negative value) or to the right.
4260 ''' plHeight : the vertical height for an area that starts at the new reference position.
4261 ''' plWidth : the horizontal width for an area that starts at the new reference position.
4262 ''' Arguments Rows and Columns must not lead to zero or negative start row or column.
4263 ''' Arguments Height and Width must not lead to zero or negative count of rows or columns.
4264 ''' Returns:
4265 ''' A new range as object of type _Address
4266 ''' Exceptions:
4267 ''' OFFSETADDRESSERROR The computed range of cells falls beyond the sheet boundaries
4269 Dim oOffset As Object ' Return value
4270 Dim oAddress As Object ' Alias of Range
4271 Dim oSheet As Object ' com.sun.star.sheet.XSpreadsheet
4272 Dim oRange As Object ' com.sun.star.table.XCellRange
4273 Dim oNewRange As Object ' com.sun.star.table.XCellRange
4274 Dim lLeft As Long ' New range coordinates
4275 Dim lTop As Long
4276 Dim lRight As Long
4277 Dim lBottom As Long
4279 Set oOffset = Nothing
4281 Check:
4284 Try:
4285 If VarType(pvRange) = V_STRING Then Set oAddress = _ParseAddress(pvRange) Else Set oAddress = pvRange
4286 Set oSheet = oAddress.XSpreadSheet
4287 Set oRange = oAddress.XCellRange.RangeAddress
4290 ' Compute and validate new coordinates
4291 With oRange
4292 lLeft = .StartColumn + plColumns
4293 lTop = .StartRow + plRows
4299 Then GoTo CatchAddress
4300 Set oNewRange = oSheet.getCellRangeByPosition(lLeft, lTop, lRight, lBottom)
4301 End With
4303 ' Define the new range address
4304 Set oOffset = New _Address
4305 With oOffset
4306 .ObjectType = CALCREFERENCE
4307 .ServiceName = SERVICEREFERENCE
4308 .RawAddress = oNewRange.AbsoluteName
4309 .Component = _Component
4310 .XSpreadsheet = oNewRange.Spreadsheet
4311 .SheetName = .XSpreadsheet.Name
4312 .SheetIndex = .XSpreadsheet.RangeAddress.Sheet
4313 .RangeName = .RawAddress
4314 .XCellRange = oNewRange
4315 .Height = oNewRange.RangeAddress.EndRow - oNewRange.RangeAddress.StartRow + 1
4316 .Width = oNewRange.RangeAddress.EndColumn - oNewRange.RangeAddress.StartColumn + 1
4317 End With
4319 Finally:
4320 Set _Offset = oOffset
4321 Exit Function
4322 Catch:
4323 GoTo Finally
4324 CatchAddress:
4325 ScriptForge.SF_Exception.RaiseFatal(OFFSETADDRESSERROR, "Range", oAddress.RawAddress _
4326 , "Rows", plRows, "Columns", plColumns, "Height", plHeight, "Width", plWidth _
4328 GoTo Finally
4329 End Function ' SFDocuments.SF_Calc._Offset
4331 REM -----------------------------------------------------------------------------
4332 Private Function _ParseAddress(ByVal psAddress As String) As Object
4333 ''' Parse and validate a sheet or range reference
4334 ''' Syntax to parse:
4335 ''' [Sheet].[Range]
4337 ''' Range => A1:D10, A1, A:D, 10:10 ($ ignored), or sheet named range or ~ or *
4338 ''' Returns:
4339 ''' An object of type _Address
4340 ''' Exceptions:
4343 Dim oAddress As Object ' Return value
4344 Dim sAddress As String ' Alias of psAddress
4345 Dim vRangeName As Variant ' Array Sheet/Range
4346 Dim lStart As Long ' Position of found regex
4347 Dim sSheet As String ' Sheet component
4348 Dim sRange As String ' Range component
4349 Dim oSheets As Object ' com.sun.star.sheet.XSpreadsheets
4350 Dim oNamedRanges As Object ' com.sun.star.sheet.XNamedRanges
4351 Dim oRangeAddress As Object ' Alias for rangeaddress
4352 Dim vLastCell As Variant ' Result of _LastCell() method
4353 Dim oSelect As Object ' Current selection
4355 ' If psAddress has already been parsed, get the result back
4356 If Not IsNull(_LastParsedAddress) Then
4357 ' Given argument must contain an explicit reference to a sheet
4358 If (InStr(psAddress, "~.") = 0 And InStr(psAddress, ".") > 0 And psAddress = _LastParsedAddress.RawAddress) _
4359 Or psAddress = _LastParsedAddress.RangeName Then
4360 Set _ParseAddress = _LastParsedAddress
4361 Exit Function
4362 Else
4363 Set _LastParsedAddress = Nothing
4364 End If
4365 End If
4367 ' Reinitialize a new _Address object
4368 Set oAddress = New _Address
4369 With oAddress
4373 .ObjectType = CALCREFERENCE
4374 .ServiceName = SERVICEREFERENCE
4375 .RawAddress = psAddress
4376 Set .XSpreadSheet = Nothing : Set .XCellRange = Nothing
4379 If Left(psAddress, 2) = "$'" Then sAddress = Mid(psAddress, 2) Else sAddress = psAddress
4380 ' Split in sheet and range components on dot not enclosed in single quotes
4381 vRangeName = ScriptForge.SF_String.SplitNotQuoted(sAddress, Delimiter := ".", QuoteChar := "'")
4382 sSheet = ScriptForge.SF_String.Unquote(Replace(vRangeName(0), "''", "\'"), QuoteChar := "'")
4384 ' Notes:
4385 ' sheet names may contain "$" (even "$" is a valid sheet name), named ranges must not
4386 ' sheet names may contain apostrophes (except in 1st and last positions), range names must not
4387 If Left(vRangeName(0), 2) <> "'$" And Left(sSheet, 1) = "$" And Len(sSheet) > 1 Then sSheet = Mid(sSheet, 2)
4390 ' Resolve sheet part: either a document named range, or the active sheet or a real sheet
4391 Set oSheets = _Component.getSheets()
4392 Set oNamedRanges = _Component.NamedRanges
4393 If oSheets.hasByName(sSheet) Then
4395 sSheet = _Component.CurrentController.ActiveSheet.Name
4396 ElseIf oNamedRanges.hasByName(sSheet) Then
4397 .XCellRange = oNamedRanges.getByName(sSheet).ReferredCells
4398 sSheet = oSheets.getByIndex(oNamedRanges.getByName(sSheet).ReferencePosition.Sheet).Name
4399 Else
4400 sRange = sSheet
4401 sSheet = _Component.CurrentController.ActiveSheet.Name
4402 End If
4403 .SheetName = sSheet
4404 .XSpreadSheet = oSheets.getByName(sSheet)
4405 .SheetIndex = .XSpreadSheet.RangeAddress.Sheet
4407 ' Resolve range part - either a sheet named range or the current selection or a real range or ""
4408 If IsNull(.XCellRange) Then
4409 Set oNamedRanges = .XSpreadSheet.NamedRanges
4411 Set oSelect = _Component.CurrentController.getSelection()
4412 If oSelect.supportsService("com.sun.star.sheet.SheetCellRanges") Then ' Multiple selections
4413 Set .XCellRange = oSelect.getByIndex(0)
4414 Else
4415 Set .XCellRange = oSelect
4416 End If
4418 vLastCell = _LastCell(.XSpreadSheet)
4420 Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange)
4421 ElseIf oNamedRanges.hasByName(sRange) Then
4422 .XCellRange = oNamedRanges.getByName(sRange).ReferredCells
4423 Else
4424 On Local Error GoTo CatchError
4425 Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange)
4426 ' If range reaches the limits of the sheets, reduce it up to the used area
4427 Set oRangeAddress = .XCellRange.RangeAddress
4429 vLastCell = _LastCell(.XSpreadSheet)
4432 Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange)
4434 vLastCell = _LastCell(.XSpreadSheet)
4435 sRange = _GetColumnName(oRangeAddress.StartColumn + 1) & "1" & ":" _
4437 Set .XCellRange = .XSpreadSheet.getCellRangeByName(sRange)
4438 End If
4439 End If
4440 End If
4441 If IsNull(.XCellRange) Then GoTo CatchAddress
4443 Set oRangeAddress = .XCellRange.RangeAddress
4444 .RangeName = .XCellRange.AbsoluteName
4445 .Height = oRangeAddress.EndRow - oRangeAddress.StartRow + 1
4446 .Width = oRangeAddress.EndColumn - oRangeAddress.StartColumn + 1
4448 ' Remember the current component in case of use outside the current instance
4449 Set .Component = _Component
4451 End With
4453 ' Store last parsed address for reuse
4454 Set _LastParsedAddress = oAddress
4456 Finally:
4457 Set _ParseAddress = oAddress
4458 Exit Function
4459 CatchError:
4460 ScriptForge.SF_Exception.Clear()
4461 CatchAddress:
4464 GoTo Finally
4465 End Function ' SFDocuments.SF_Calc._ParseAddress
4467 REM -----------------------------------------------------------------------------
4468 Private Function _PropertyGet(Optional ByVal psProperty As String _
4469 , Optional ByVal pvArg As Variant _
4470 ) As Variant
4471 ''' Return the value of the named property
4472 ''' Args:
4473 ''' psProperty: the name of the property
4475 Dim oProperties As Object ' Document or Custom properties
4476 Dim vLastCell As Variant ' Coordinates of last used cell in a sheet
4477 Dim oSelect As Object ' Current selection
4478 Dim vRanges As Variant ' List of selected ranges
4479 Dim oAddress As Object ' _Address type for range description
4480 Dim oCursor As Object ' com.sun.star.sheet.XSheetCellCursor
4481 Dim i As Long
4482 Dim cstThisSub As String
4483 Const cstSubArgs = ""
4485 _PropertyGet = False
4488 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
4489 If Not _IsStillAlive() Then GoTo Finally
4491 Select Case UCase(psProperty)
4493 Set oSelect = _Component.CurrentController.getSelection()
4494 If IsNull(oSelect) Then
4495 _PropertyGet = Array()
4496 ElseIf oSelect.supportsService("com.sun.star.sheet.SheetCellRanges") Then ' Multiple selections
4497 vRanges = Array()
4499 vRanges = ScriptForge.SF_Array.Append(vRanges, oSelect.getByIndex(i).AbsoluteName)
4500 Next i
4501 _PropertyGet = vRanges
4502 Else
4503 _PropertyGet = oSelect.AbsoluteName
4504 End If
4506 If IsMissing(pvArg) Or IsEmpty(pvArg) Then
4507 _PropertyGet = 0
4508 Else
4510 _PropertyGet = _ParseAddress(pvArg).Height
4511 End If
4512 Case UCase("FirstCell"), UCase("FirstRow"), UCase("FirstColumn") _
4515 If IsMissing(pvArg) Or IsEmpty(pvArg) Then ' Avoid errors when instance is watched in Basic IDE
4516 If InStr(UCase(psProperty), "CELL") > 0 Then _PropertyGet = "" Else _PropertyGet = -1
4517 Else
4519 Set oAddress = _ParseAddress(pvArg)
4520 With oAddress.XCellRange
4521 Select Case UCase(psProperty)
4523 _PropertyGet = A1Style(.RangeAddress.StartRow + 1, .RangeAddress.StartColumn + 1, , , oAddress.XSpreadsheet.Name)
4527 _PropertyGet = A1Style(.RangeAddress.EndRow + 1, .RangeAddress.EndColumn + 1, , , oAddress.XSpreadsheet.Name)
4531 End Select
4532 End With
4533 End If
4535 If IsMissing(pvArg) Or IsEmpty(pvArg) Then
4536 Set _PropertyGet = Nothing
4537 Else
4539 Set _PropertyGet = _ParseAddress(pvArg)
4540 End If
4542 If IsMissing(pvArg) Or IsEmpty(pvArg) Then
4543 _PropertyGet = ""
4544 Else
4546 Set oAddress = _ParseAddress(pvArg)
4547 With oAddress
4548 Set oCursor = .XSpreadsheet.createCursorByRange(.XCellRange)
4549 oCursor.collapseToCurrentRegion()
4550 _PropertyGet = oCursor.AbsoluteName
4551 End With
4552 End If
4554 If IsMissing(pvArg) Or IsEmpty(pvArg) Then
4555 Set _PropertyGet = Nothing
4556 Else
4558 Set _PropertyGet = _ParseAddress(pvArg)
4559 End If
4561 _PropertyGet = _Component.getSheets.getElementNames()
4563 If IsMissing(pvArg) Or IsEmpty(pvArg) Then
4564 _PropertyGet = 0
4565 Else
4567 _PropertyGet = _ParseAddress(pvArg).Width
4568 End If
4570 If IsMissing(pvArg) Or IsEmpty(pvArg) Then
4571 Set _PropertyGet = Nothing
4572 Else
4574 Set _PropertyGet = _ParseAddress(pvArg).XCellRange
4575 End If
4577 If IsMissing(pvArg) Or IsEmpty(pvArg) Then
4578 Set _PropertyGet = Nothing
4579 Else
4581 Set _PropertyGet = _RangePosition(pvArg)
4582 End If
4584 If IsMissing(pvArg) Or IsEmpty(pvArg) Then
4585 Set _PropertyGet = Nothing
4586 Else
4588 Set oAddress = _ParseAddress(pvArg)
4589 Set _PropertyGet = oAddress.XSpreadsheet.createCursorByRange(oAddress.XCellRange)
4590 End If
4592 If IsMissing(pvArg) Or IsEmpty(pvArg) Then
4593 Set _PropertyGet = Nothing
4594 Else
4596 Set _PropertyGet = _Component.getSheets.getByName(pvArg)
4597 End If
4598 Case Else
4599 _PropertyGet = Null
4600 End Select
4602 Finally:
4603 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
4604 Exit Function
4605 End Function ' SFDocuments.SF_Calc._PropertyGet
4607 REM -----------------------------------------------------------------------------
4608 Private Function _QuoteSheetName(ByVal psSheetName As String) As String
4609 ''' Return the given sheet name surrounded with single quotes
4610 ''' when required to insert the sheet name into a Calc formula
4611 ''' Enclosed single quotes are doubled
4612 ''' Args:
4613 ''' psSheetName: the name to quote
4614 ''' Returns:
4615 ''' The quoted or unchanged sheet name
4617 Dim sSheetName As String ' Return value
4618 Dim i As Long
4620 Try:
4621 ' Surround the sheet name with single quotes when required by the presence of single quotes
4623 sSheetName = "'" & Replace(psSheetName, "'", "''") & "'"
4624 Else
4625 ' Surround the sheet name with single quotes when required by the presence of at least one of the special characters
4626 sSheetName = psSheetName
4627 For i = 1 To Len(cstSPECIALCHARS)
4630 Exit For
4631 End If
4632 Next i
4633 End If
4635 Finally:
4636 _QuoteSheetName = sSheetName
4637 Exit Function
4638 End Function ' SFDocuments.SF_Calc._QuoteSheetName
4640 REM -----------------------------------------------------------------------------
4641 Private Function _RangePosition(ByVal psRange As String) As Object
4642 ''' Determine a best guess of the coordinates (in pixels) of the given range
4643 ''' Inspired (and enhanced) from https://forum.openoffice.org/en/forum/viewtopic.php?p=308693#p308693
4644 ''' Args:
4645 ''' psRange: the range as a string
4646 ''' Returns:
4647 ''' a com.sun.star.awt.Rectangle UNO structure
4649 Dim oRectOnScreen As New com.sun.star.awt.Rectangle ' Range position versus top-left screen corner (return value)
4650 Dim oRect As New com.sun.star.awt.Rectangle ' Range position versus the A1 cell
4651 Dim oLocation As Object ' com.sun.star.awt.Rectangle
4652 Dim oController As Object ' Current controller
4653 Dim oXRange As Object ' com.sun.star.Table.CellRange
4655 Check:
4656 On Local Error GoTo Finally
4658 Try:
4659 Set oController = _Component.CurrentController
4660 Set oXRange = _ParseAddress(psRange).XCellRange
4661 ' Grab the window location on the screen
4662 Set oLocation = oController.ComponentWindow.AccessibleContext.LocationOnScreen
4664 With oRect
4665 .X = oXRange.Position.X
4666 .Y = oXRange.Position.Y
4667 .Width = oXRange.Size.Width
4668 .Height = oXRange.Size.Height
4669 End With
4671 'Compute the rectangle in pixels (empirical computation)
4672 With oController
4673 oRectOnScreen.X = .VisibleAreaOnScreen.X _
4674 + .VisibleAreaOnScreen.Width * (oRect.X - .VisibleArea.X) / .VisibleArea.Width _
4675 - oLocation.X
4676 oRectOnScreen.Y = .VisibleAreaOnScreen.Y _
4677 + .VisibleAreaOnScreen.Height * (oRect.Y - .VisibleArea.Y) / .VisibleArea.Height _
4678 - oLocation.Y
4679 oRectOnScreen.Width = oRect.Width * .VisibleAreaOnScreen.Width / .VisibleArea.Width
4680 oRectOnScreen.Height = oRect.Height * .VisibleAreaOnScreen.Height / .VisibleArea.Height
4681 End With
4683 Finally:
4684 Set _RangePosition = oRectOnScreen
4685 Exit Function
4686 End Function ' SFDocuments.SF_Calc._RangePosition
4688 REM -----------------------------------------------------------------------------
4689 Private Function _Repr() As String
4690 ''' Convert the SF_Calc instance to a readable string, typically for debugging purposes (DebugPrint ...)
4691 ''' Args:
4692 ''' Return:
4697 End Function ' SFDocuments.SF_Calc._Repr
4699 REM -----------------------------------------------------------------------------
4700 Private Sub _RestoreSelections(ByRef pvComponent As Variant _
4701 , ByRef pvSelection As Variant _
4702 )
4703 ''' Set the selection to a single or a multiple range
4704 ''' Does not work well when multiple selections and macro terminating in Basic IDE
4705 ''' Called by the CopyToCell and CopyToRange methods
4706 ''' Args:
4707 ''' pvComponent: should work for foreign instances as well
4708 ''' pvSelection: the stored selection done previously by Component.CurrentController.getSelection()
4710 Dim oCellRanges As Object ' com.sun.star.sheet.SheetCellRanges
4711 Dim vRangeAddresses As Variant ' Array of com.sun.star.table.CellRangeAddress
4712 Dim i As Long
4714 Try:
4715 If IsArray(pvSelection) Then
4717 vRangeAddresses = Array()
4718 ReDim vRangeAddresses(0 To UBound(pvSelection))
4719 For i = 0 To UBound(pvSelection)
4720 vRangeAddresses(i) = pvSelection.getByIndex(i).RangeAddress
4721 Next i
4722 oCellRanges.addRangeAddresses(vRangeAddresses, False)
4723 pvComponent.CurrentController.select(oCellRanges)
4724 Else
4725 pvComponent.CurrentController.select(pvSelection)
4726 End If
4728 Finally:
4729 Exit Sub
4730 End Sub ' SFDocuments.SF_Calc._RestoreSelections
4732 REM -----------------------------------------------------------------------------
4733 Private Function _ValidateSheet(Optional ByRef pvSheetName As Variant _
4734 , Optional ByVal psArgName As String _
4735 , Optional ByVal pvNew As Variant _
4736 , Optional ByVal pvActive As Variant _
4737 , Optional ByVal pvOptional as Variant _
4738 , Optional ByVal pvNumeric As Variant _
4739 , Optional ByVal pvReference As Variant _
4740 , Optional ByVal pvResetSheet As Variant _
4741 ) As Boolean
4742 ''' Sheet designation validation function similar to the SF_Utils._ValidateXXX functions
4743 ''' Args:
4744 ''' pvSheetName: string or numeric position
4745 ''' pvArgName: the name of the variable to be used in the error message
4746 ''' pvNew: if True, sheet must not exist (default = False)
4748 ''' pvOptional: if True, a zero-length string is accepted (default = False)
4749 ''' pvNumeric: if True, the sheet position is accepted (default = False)
4750 ''' pvReference: if True, a sheet reference is acceptable (default = False)
4751 ''' pvNumeric and pvReference must not both be = True
4752 ''' pvResetSheet: if True, return in pvSheetName the correct (case-sensitive) sheet name (default = False)
4753 ''' Returns
4755 ''' Exceptions
4756 ''' DUPLICATESHEETERROR A sheet with the given name exists already
4758 Dim vSheets As Variant ' List of sheets
4759 Dim lSheet As Long ' Index in list of sheets
4760 Dim vTypes As Variant ' Array of accepted variable types
4761 Dim bValid As Boolean ' Return value
4763 Check:
4764 If IsMissing(pvNew) Or IsEmpty(pvNew) Then pvNew = False
4765 If IsMissing(pvActive) Or IsEmpty(pvActive) Then pvActive = False
4766 If IsMissing(pvOptional) Or IsEmpty(pvOptional) Then pvOptional = False
4767 If IsMissing(pvNumeric) Or IsEmpty(pvNumeric) Then pvNumeric = False
4768 If IsMissing(pvReference) Or IsEmpty(pvReference) Then pvReference = False
4769 If IsMissing(pvResetSheet) Or IsEmpty(pvResetSheet) Then pvResetSheet = False
4771 ' Define the acceptable variable types
4772 If pvNumeric Then
4773 vTypes = Array(V_STRING, V_NUMERIC)
4774 ElseIf pvReference Then
4775 vTypes = Array(V_STRING, ScriptForge.V_OBJECT)
4776 Else
4777 vTypes = V_STRING
4778 End If
4779 If Not ScriptForge.SF_Utils._Validate(pvSheetName, psArgName, vTypes, , , Iif(pvReference, CALCREFERENCE, "")) Then GoTo Finally
4780 bValid = False
4782 Try:
4783 If VarType(pvSheetName) = V_STRING Then
4784 If pvOptional And Len(pvSheetName) = 0 Then
4786 pvSheetName = _Component.CurrentController.ActiveSheet.Name
4787 Else
4788 vSheets = _Component.getSheets.getElementNames()
4789 If pvNew Then
4791 If ScriptForge.SF_Array.Contains(vSheets, pvSheetName) Then GoTo CatchDuplicate
4792 Else
4793 If Not ScriptForge.SF_Utils._Validate(pvSheetName, psArgName, V_STRING, vSheets) Then GoTo Finally
4794 If pvResetSheet Then
4795 lSheet = ScriptForge.SF_Array.IndexOf(vSheets, pvSheetName, CaseSensitive := False)
4796 pvSheetName = vSheets(lSheet)
4797 End If
4798 End If
4799 End If
4800 End If
4801 bValid = True
4803 Finally:
4804 _ValidateSheet = bValid
4805 Exit Function
4806 CatchDuplicate:
4807 ScriptForge.SF_Exception.RaiseFatal(DUPLICATESHEETERROR, psArgName, pvSheetName, "Document", [_Super]._FileIdent())
4808 GoTo Finally
4809 End Function ' SFDocuments.SF_Calc._ValidateSheet
4811 REM -----------------------------------------------------------------------------
4812 Private Function _ValidateSheetName(ByRef psSheetName As String _
4813 , ByVal psArgName As String _
4814 ) As Boolean
4815 ''' Check the validity of the sheet name:
4816 ''' A sheet name - must not be empty
4817 ''' - must not contain next characters: []*?:/\
4819 ''' Args:
4820 ''' psSheetName: the name to check
4821 ''' psArgName: the name of the argument to appear in error messages
4822 ''' Returns:
4823 ''' True when the sheet name is valid
4824 ''' Exceptions:
4827 Dim bValid As Boolean ' Return value
4829 Try:
4831 If bValid Then bValid = ( Left(psSheetName, 1) <> "'" And Right(psSheetName, 1) <> "'" )
4832 If bValid Then bValid = ( Len(ScriptForge.SF_String.FindRegex(psSheetName, "^[^\[\]*?:\/\\]+$", 1, CaseSensitive := False)) > 0 )
4833 If Not bValid Then GoTo CatchSheet
4835 Finally:
4836 _ValidateSheetName = bValid
4837 Exit Function
4838 CatchSheet:
4839 ScriptForge.SF_Exception.RaiseFatal(CALCADDRESSERROR, psArgName, psSheetName _
4841 GoTo Finally
4842 End Function ' SFDocuments.SF_Calc._ValidateSheetName
4844 REM ============================================ END OF SFDOCUMENTS.SF_CALC
4845 </script:module>