diff options
Diffstat (limited to 'wizards/source/sfdialogs/SF_DialogControl.xba')
| -rw-r--r-- | wizards/source/sfdialogs/SF_DialogControl.xba | 2084 |
1 files changed, 2084 insertions, 0 deletions
diff --git a/wizards/source/sfdialogs/SF_DialogControl.xba b/wizards/source/sfdialogs/SF_DialogControl.xba new file mode 100644 index 000000000..f4a0891d9 --- /dev/null +++ b/wizards/source/sfdialogs/SF_DialogControl.xba @@ -0,0 +1,2084 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_DialogControl" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFDialogs library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_DialogControl +''' ================ +''' Manage the controls belonging to a dialog defined with the Basic IDE +''' Each instance of the current class represents a single control within a dialog box +''' +''' The focus is clearly set on getting and setting the values displayed by the controls of the dialog box, +''' not on their formatting. The latter is easily accessible via the XControlModel and XControlView +''' UNO objects. +''' Essentially a single property "Value" maps many alternative UNO properties depending each on +''' the control type. +''' +''' A special attention is given to controls with types TreeControl and TableControl +''' It is easy with the API proposed in the current class to populate a tree, either +''' - branch by branch (CreateRoot and AddSubNode), or +''' - with a set of branches at once (AddSubtree) +''' Additionally populating a TreeControl can be done statically or dynamically +''' +''' With the method SetTableData(), feed a tablecontrol with a sortable and selectable +''' array of data. Columns and rows may receive a header. Column widths are adjusted manually by the user or +''' with the same method. Alignments can be set as well by script. +''' +''' Service invocation: +''' Dim myDialog As Object, myControl As Object +''' Set myDialog = CreateScriptService("SFDialogs.Dialog", "GlobalScope", myLibrary, DialogName) +''' Set myControl = myDialog.Controls("myTextBox") +''' myControl.Value = "Dialog started at " & Now() +''' myDialog.Execute() +''' ' ... process the controls actual values +''' myDialog.Terminate() +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_dialogcontrol.html?DbPAR=BASIC +''' +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const CONTROLTYPEERROR = "CONTROLTYPEERROR" +Private Const TEXTFIELDERROR = "TEXTFIELDERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be DIALOGCONTROL +Private ServiceName As String + +' Control naming +Private _Name As String +Private _IndexOfNames As Long ' Index in ElementNames array. Used to access SF_Dialog._ControlCache +Private _DialogName As String ' Parent dialog name + +' Control UNO references +Private _ControlModel As Object ' com.sun.star.awt.XControlModel +Private _ControlView As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl +Private _TreeDataModel As Object ' com.sun.star.awt.tree.MutableTreeDataModel +Private _GridColumnModel As Object ' com.sun.star.awt.grid.XGridColumnModel +Private _GridDataModel As Object ' com.sun.star.awt.grid.XGridDataModel + +' Control attributes +Private _ImplementationName As String +Private _ControlType As String ' One of the CTLxxx constants + +' Tree control on-select and on-expand attributes +' Tree controls may be associated with events not defined in the Basic IDE +Private _OnNodeSelected As String ' Script to invoke when a node is selected +Private _OnNodeExpanded As String ' Script to invoke when a node is expanded +Private _SelectListener As Object ' com.sun.star.view.XSelectionChangeListener +Private _ExpandListener As Object ' com.sun.star.awt.tree.XTreeExpansionListener + +' Table control attributes +Private _ColumnWidths As Variant ' Array of column widths + +REM ============================================================ MODULE CONSTANTS + +Private Const CTLBUTTON = "Button" +Private Const CTLCHECKBOX = "CheckBox" +Private Const CTLCOMBOBOX = "ComboBox" +Private Const CTLCURRENCYFIELD = "CurrencyField" +Private Const CTLDATEFIELD = "DateField" +Private Const CTLFILECONTROL = "FileControl" +Private Const CTLFIXEDLINE = "FixedLine" +Private Const CTLFIXEDTEXT = "FixedText" +Private Const CTLFORMATTEDFIELD = "FormattedField" +Private Const CTLGROUPBOX = "GroupBox" +Private Const CTLIMAGECONTROL = "ImageControl" +Private Const CTLLISTBOX = "ListBox" +Private Const CTLNUMERICFIELD = "NumericField" +Private Const CTLPATTERNFIELD = "PatternField" +Private Const CTLPROGRESSBAR = "ProgressBar" +Private Const CTLRADIOBUTTON = "RadioButton" +Private Const CTLSCROLLBAR = "ScrollBar" +Private Const CTLTABLECONTROL = "TableControl" +Private Const CTLTEXTFIELD = "TextField" +Private Const CTLTIMEFIELD = "TimeField" +Private Const CTLTREECONTROL = "TreeControl" + +REM ====================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "DIALOGCONTROL" + ServiceName = "SFDialogs.DialogControl" + _Name = "" + _IndexOfNames = -1 + _DialogName = "" + Set _ControlModel = Nothing + Set _ControlView = Nothing + Set _TreeDataModel = Nothing + Set _GridColumnModel = Nothing + Set _GridDataModel = Nothing + _ImplementationName = "" + _ControlType = "" + _OnNodeSelected = "" + _OnNodeExpanded = "" + Set _SelectListener = Nothing + Set _ExpandListener = Nothing + _ColumnWidths = Array() +End Sub ' SFDialogs.SF_DialogControl Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + Call Class_Initialize() +End Sub ' SFDialogs.SF_DialogControl Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFDialogs.SF_DialogControl Explicit Destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get Cancel() As Variant +''' The Cancel property specifies if a command button has or not the behaviour of a Cancel button. + Cancel = _PropertyGet("Cancel", False) +End Property ' SFDialogs.SF_DialogControl.Cancel (get) + +REM ----------------------------------------------------------------------------- +Property Let Cancel(Optional ByVal pvCancel As Variant) +''' Set the updatable property Cancel + _PropertySet("Cancel", pvCancel) +End Property ' SFDialogs.SF_DialogControl.Cancel (let) + +REM ----------------------------------------------------------------------------- +Property Get Caption() As Variant +''' The Caption property refers to the text associated with the control + Caption = _PropertyGet("Caption", "") +End Property ' SFDialogs.SF_DialogControl.Caption (get) + +REM ----------------------------------------------------------------------------- +Property Let Caption(Optional ByVal pvCaption As Variant) +''' Set the updatable property Caption + _PropertySet("Caption", pvCaption) +End Property ' SFDialogs.SF_DialogControl.Caption (let) + +REM ----------------------------------------------------------------------------- +Property Get ControlType() As String +''' Return the type of the actual control: "CheckBox", "TextField", "DateField", ... + ControlType = _PropertyGet("ControlType") +End Property ' SFDialogs.SF_DialogControl.ControlType + +REM ----------------------------------------------------------------------------- +Property Get CurrentNode() As Variant +''' The CurrentNode property returns the currently selected node +''' It returns Empty when there is no node selected +''' When there are several selections, it returns the topmost node among the selected ones + CurrentNode = _PropertyGet("CurrentNode", "") +End Property ' SFDialogs.SF_DialogControl.CurrentNode (get) + +REM ----------------------------------------------------------------------------- +Property Let CurrentNode(Optional ByVal pvCurrentNode As Variant) +''' Set a single selection in a tree control + _PropertySet("CurrentNode", pvCurrentNode) +End Property ' SFDialogs.SF_DialogControl.CurrentNode (let) + +REM ----------------------------------------------------------------------------- +Property Get Default() As Variant +''' The Default property specifies whether a command button is the default (OK) button. + Default = _PropertyGet("Default", False) +End Property ' SFDialogs.SF_DialogControl.Default (get) + +REM ----------------------------------------------------------------------------- +Property Let Default(Optional ByVal pvDefault As Variant) +''' Set the updatable property Default + _PropertySet("Default", pvDefault) +End Property ' SFDialogs.SF_DialogControl.Default (let) + +REM ----------------------------------------------------------------------------- +Property Get Enabled() As Variant +''' The Enabled property specifies if the control is accessible with the cursor. + Enabled = _PropertyGet("Enabled") +End Property ' SFDialogs.SF_DialogControl.Enabled (get) + +REM ----------------------------------------------------------------------------- +Property Let Enabled(Optional ByVal pvEnabled As Variant) +''' Set the updatable property Enabled + _PropertySet("Enabled", pvEnabled) +End Property ' SFDialogs.SF_DialogControl.Enabled (let) + +REM ----------------------------------------------------------------------------- +Property Get Format() As Variant +''' The Format property specifies the format in which to display dates and times. + Format = _PropertyGet("Format", "") +End Property ' SFDialogs.SF_DialogControl.Format (get) + +REM ----------------------------------------------------------------------------- +Property Let Format(Optional ByVal pvFormat As Variant) +''' Set the updatable property Format +''' NB: Format is read-only for formatted field controls + _PropertySet("Format", pvFormat) +End Property ' SFDialogs.SF_DialogControl.Format (let) + +REM ----------------------------------------------------------------------------- +Property Get ListCount() As Long +''' The ListCount property specifies the number of rows in a list box or a combo box + ListCount = _PropertyGet("ListCount", 0) +End Property ' SFDialogs.SF_DialogControl.ListCount (get) + +REM ----------------------------------------------------------------------------- +Property Get ListIndex() As Variant +''' The ListIndex property specifies which item is selected in a list box or combo box. +''' In case of multiple selection, the index of the first one is returned or only one is set + ListIndex = _PropertyGet("ListIndex", -1) +End Property ' SFDialogs.SF_DialogControl.ListIndex (get) + +REM ----------------------------------------------------------------------------- +Property Let ListIndex(Optional ByVal pvListIndex As Variant) +''' Set the updatable property ListIndex + _PropertySet("ListIndex", pvListIndex) +End Property ' SFDialogs.SF_DialogControl.ListIndex (let) + +REM ----------------------------------------------------------------------------- +Property Get Locked() As Variant +''' The Locked property specifies if a control is read-only + Locked = _PropertyGet("Locked", False) +End Property ' SFDialogs.SF_DialogControl.Locked (get) + +REM ----------------------------------------------------------------------------- +Property Let Locked(Optional ByVal pvLocked As Variant) +''' Set the updatable property Locked + _PropertySet("Locked", pvLocked) +End Property ' SFDialogs.SF_DialogControl.Locked (let) + +REM ----------------------------------------------------------------------------- +Property Get MultiSelect() As Variant +''' The MultiSelect property specifies whether a user can make multiple selections in a listbox + MultiSelect = _PropertyGet("MultiSelect", False) +End Property ' SFDialogs.SF_DialogControl.MultiSelect (get) + +REM ----------------------------------------------------------------------------- +Property Let MultiSelect(Optional ByVal pvMultiSelect As Variant) +''' Set the updatable property MultiSelect + _PropertySet("MultiSelect", pvMultiSelect) +End Property ' SFDialogs.SF_DialogControl.MultiSelect (let) + +REM ----------------------------------------------------------------------------- +Property Get Name() As String +''' Return the name of the actual control + Name = _PropertyGet("Name") +End Property ' SFDialogs.SF_DialogControl.Name + +REM ----------------------------------------------------------------------------- +Property Get OnActionPerformed() As Variant +''' Get the script associated with the OnActionPerformed event + OnActionPerformed = _PropertyGet("OnActionPerformed") +End Property ' SFDialogs.SF_DialogControl.OnActionPerformed (get) + +REM ----------------------------------------------------------------------------- +Property Get OnAdjustmentValueChanged() As Variant +''' Get the script associated with the OnAdjustmentValueChanged event + OnAdjustmentValueChanged = _PropertyGet("OnAdjustmentValueChanged") +End Property ' SFDialogs.SF_DialogControl.OnAdjustmentValueChanged (get) + +REM ----------------------------------------------------------------------------- +Property Get OnFocusGained() As Variant +''' Get the script associated with the OnFocusGained event + OnFocusGained = _PropertyGet("OnFocusGained") +End Property ' SFDialogs.SF_DialogControl.OnFocusGained (get) + +REM ----------------------------------------------------------------------------- +Property Get OnFocusLost() As Variant +''' Get the script associated with the OnFocusLost event + OnFocusLost = _PropertyGet("OnFocusLost") +End Property ' SFDialogs.SF_DialogControl.OnFocusLost (get) + +REM ----------------------------------------------------------------------------- +Property Get OnItemStateChanged() As Variant +''' Get the script associated with the OnItemStateChanged event + OnItemStateChanged = _PropertyGet("OnItemStateChanged") +End Property ' SFDialogs.SF_DialogControl.OnItemStateChanged (get) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyPressed() As Variant +''' Get the script associated with the OnKeyPressed event + OnKeyPressed = _PropertyGet("OnKeyPressed") +End Property ' SFDialogs.SF_DialogControl.OnKeyPressed (get) + +REM ----------------------------------------------------------------------------- +Property Get OnKeyReleased() As Variant +''' Get the script associated with the OnKeyReleased event + OnKeyReleased = _PropertyGet("OnKeyReleased") +End Property ' SFDialogs.SF_DialogControl.OnKeyReleased (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseDragged() As Variant +''' Get the script associated with the OnMouseDragged event + OnMouseDragged = _PropertyGet("OnMouseDragged") +End Property ' SFDialogs.SF_DialogControl.OnMouseDragged (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseEntered() As Variant +''' Get the script associated with the OnMouseEntered event + OnMouseEntered = _PropertyGet("OnMouseEntered") +End Property ' SFDialogs.SF_DialogControl.OnMouseEntered (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseExited() As Variant +''' Get the script associated with the OnMouseExited event + OnMouseExited = _PropertyGet("OnMouseExited") +End Property ' SFDialogs.SF_DialogControl.OnMouseExited (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseMoved() As Variant +''' Get the script associated with the OnMouseMoved event + OnMouseMoved = _PropertyGet("OnMouseMoved") +End Property ' SFDialogs.SF_DialogControl.OnMouseMoved (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMousePressed() As Variant +''' Get the script associated with the OnMousePressed event + OnMousePressed = _PropertyGet("OnMousePressed") +End Property ' SFDialogs.SF_DialogControl.OnMousePressed (get) + +REM ----------------------------------------------------------------------------- +Property Get OnMouseReleased() As Variant +''' Get the script associated with the OnMouseReleased event + OnMouseReleased = _PropertyGet("OnMouseReleased") +End Property ' SFDialogs.SF_DialogControl.OnMouseReleased (get) + +REM ----------------------------------------------------------------------------- +Property Get OnNodeExpanded() As Variant +''' Get the script associated with the OnNodeExpanded event + OnNodeExpanded = _PropertyGet("OnNodeExpanded") +End Property ' SFDialogs.SF_DialogControl.OnNodeExpanded (get) + +REM ----------------------------------------------------------------------------- +Property Let OnNodeExpanded(Optional ByVal pvOnNodeExpanded As Variant) +''' Set the updatable property OnNodeExpanded + _PropertySet("OnNodeExpanded", pvOnNodeExpanded) +End Property ' SFDialogs.SF_DialogControl.OnNodeExpanded (let) + +REM ----------------------------------------------------------------------------- +Property Get OnNodeSelected() As Variant +''' Get the script associated with the OnNodeSelected event + OnNodeSelected = _PropertyGet("OnNodeSelected") +End Property ' SFDialogs.SF_DialogControl.OnNodeSelected (get) + +REM ----------------------------------------------------------------------------- +Property Let OnNodeSelected(Optional ByVal pvOnNodeSelected As Variant) +''' Set the updatable property OnNodeSelected + _PropertySet("OnNodeSelected", pvOnNodeSelected) +End Property ' SFDialogs.SF_DialogControl.OnNodeSelected (let) + +REM ----------------------------------------------------------------------------- +Property Get OnTextChanged() As Variant +''' Get the script associated with the OnTextChanged event + OnTextChanged = _PropertyGet("OnTextChanged") +End Property ' SFDialogs.SF_DialogControl.OnTextChanged (get) + +REM ----------------------------------------------------------------------------- +Property Get Page() As Variant +''' A dialog may have several pages that can be traversed by the user step by step. The Page property of the Dialog object defines which page of the dialog is active. +''' The Page property of a control defines the page of the dialog on which the control is visible. +''' For example, if a control has a page value of 1, it is only visible on page 1 of the dialog. +''' If the page value of the dialog is increased from 1 to 2, then all controls with a page value of 1 disappear and all controls with a page value of 2 become visible. + Page = _PropertyGet("Page") +End Property ' SFDialogs.SF_DialogControl.Page (get) + +REM ----------------------------------------------------------------------------- +Property Let Page(Optional ByVal pvPage As Variant) +''' Set the updatable property Page + _PropertySet("Page", pvPage) +End Property ' SFDialogs.SF_DialogControl.Page (let) + +REM ----------------------------------------------------------------------------- +Property Get Parent() As Object +''' Return the Parent dialog object of the actual control + Parent = _PropertyGet("Parent", Nothing) +End Property ' SFDialogs.SF_DialogControl.Parent + +REM ----------------------------------------------------------------------------- +Property Get Picture() As Variant +''' The Picture property specifies a bitmap or other type of graphic to be displayed on the specified control + Picture = _PropertyGet("Picture", "") +End Property ' SFDialogs.SF_DialogControl.Picture (get) + +REM ----------------------------------------------------------------------------- +Property Let Picture(Optional ByVal pvPicture As Variant) +''' Set the updatable property Picture + _PropertySet("Picture", pvPicture) +End Property ' SFDialogs.SF_DialogControl.Picture (let) + +REM ----------------------------------------------------------------------------- +Property Get RootNode() As Variant +''' The RootNode property returns the last root node of a tree control + RootNode = _PropertyGet("RootNode", "") +End Property ' SFDialogs.SF_DialogControl.RootNode (get) + +REM ----------------------------------------------------------------------------- +Property Get RowSource() As Variant +''' The RowSource property specifies the data contained in a combobox or a listbox +''' as a zero-based array of string values + RowSource = _PropertyGet("RowSource", "") +End Property ' SFDialogs.SF_DialogControl.RowSource (get) + +REM ----------------------------------------------------------------------------- +Property Let RowSource(Optional ByVal pvRowSource As Variant) +''' Set the updatable property RowSource + _PropertySet("RowSource", pvRowSource) +End Property ' SFDialogs.SF_DialogControl.RowSource (let) + +REM ----------------------------------------------------------------------------- +Property Get Text() As Variant +''' The Text property specifies the actual content of the control like it is displayed on the screen + Text = _PropertyGet("Text", "") +End Property ' SFDialogs.SF_DialogControl.Text (get) + +REM ----------------------------------------------------------------------------- +Property Get TipText() As Variant +''' The TipText property specifies the text that appears in a screentip when you hold the mouse pointer over a control + TipText = _PropertyGet("TipText", "") +End Property ' SFDialogs.SF_DialogControl.TipText (get) + +REM ----------------------------------------------------------------------------- +Property Let TipText(Optional ByVal pvTipText As Variant) +''' Set the updatable property TipText + _PropertySet("TipText", pvTipText) +End Property ' SFDialogs.SF_DialogControl.TipText (let) + +REM ----------------------------------------------------------------------------- +Property Get TripleState() As Variant +''' The TripleState property specifies how a check box will display Null values +''' When True, the control will cycle through states for Yes, No, and Null values. The control appears dimmed (grayed) when its Value property is set to Null. +''' When False, the control will cycle through states for Yes and No values. Null values display as if they were No values. + TripleState = _PropertyGet("TripleState", False) +End Property ' SFDialogs.SF_DialogControl.TripleState (get) + +REM ----------------------------------------------------------------------------- +Property Let TripleState(Optional ByVal pvTripleState As Variant) +''' Set the updatable property TripleState + _PropertySet("TripleState", pvTripleState) +End Property ' SFDialogs.SF_DialogControl.TripleState (let) + +REM ----------------------------------------------------------------------------- +Property Get Value() As Variant +''' The Value property specifies the data contained in the control + Value = _PropertyGet("Value", Empty) +End Property ' SFDialogs.SF_DialogControl.Value (get) + +REM ----------------------------------------------------------------------------- +Property Let Value(Optional ByVal pvValue As Variant) +''' Set the updatable property Value + _PropertySet("Value", pvValue) +End Property ' SFDialogs.SF_DialogControl.Value (let) + +REM ----------------------------------------------------------------------------- +Property Get Visible() As Variant +''' The Visible property specifies if the control is accessible with the cursor. + Visible = _PropertyGet("Visible", True) +End Property ' SFDialogs.SF_DialogControl.Visible (get) + +REM ----------------------------------------------------------------------------- +Property Let Visible(Optional ByVal pvVisible As Variant) +''' Set the updatable property Visible + _PropertySet("Visible", pvVisible) +End Property ' SFDialogs.SF_DialogControl.Visible (let) + +REM ----------------------------------------------------------------------------- +Property Get XControlModel() As Object +''' The XControlModel property returns the model UNO object of the control + XControlModel = _PropertyGet("XControlModel", Nothing) +End Property ' SFDialogs.SF_DialogControl.XControlModel (get) + +REM ----------------------------------------------------------------------------- +Property Get XControlView() As Object +''' The XControlView property returns the view UNO object of the control + XControlView = _PropertyGet("XControlView", Nothing) +End Property ' SFDialogs.SF_DialogControl.XControlView (get) + +REM ----------------------------------------------------------------------------- +Property Get XGridColumnModel() As Object +''' The XGridColumnModel property returns the mutable data model UNO object of the tree control + XGridColumnModel = _PropertyGet("XGridColumnModel", Nothing) +End Property ' SFDialogs.SF_DialogControl.XGridColumnModel (get) + +REM ----------------------------------------------------------------------------- +Property Get XGridDataModel() As Object +''' The XGridDataModel property returns the mutable data model UNO object of the tree control + XGridDataModel = _PropertyGet("XGridDataModel", Nothing) +End Property ' SFDialogs.SF_DialogControl.XGridDataModel (get) + +REM ----------------------------------------------------------------------------- +Property Get XTreeDataModel() As Object +''' The XTreeDataModel property returns the mutable data model UNO object of the tree control + XTreeDataModel = _PropertyGet("XTreeDataModel", Nothing) +End Property ' SFDialogs.SF_DialogControl.XTreeDataModel (get) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function AddSubNode(Optional ByRef ParentNode As Variant _ + , Optional ByVal DisplayValue As Variant _ + , Optional ByRef DataValue As Variant _ + ) As Variant +''' Return a new node of the tree control subordinate to a parent node +''' Args: +''' ParentNode: A node UNO object, of type com.sun.star.awt.tree.XMutableTreeNode +''' DisplayValue: the text appearing in the control box +''' DataValue: any value associated with the new node. Default = Empty +''' Returns: +''' The new node UNO object: com.sun.star.awt.tree.XMutableTreeNode +''' Examples: +''' Dim myTree As Object, myNode As Object, theRoot As Object +''' Set myTree = myDialog.Controls("myTreeControl") +''' Set theRoot = myTree.CreateRoot("Tree top") +''' Set myNode = myTree.AddSubNode(theRoot, "A branch ...") + +Dim oNode As Object ' Return value +Const cstThisSub = "SFDialogs.DialogControl.AddSubNode" +Const cstSubArgs = "ParentNode, DisplayValue, [DataValue=Empty]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oNode = Nothing + +Check: + If IsMissing(DataValue) Then DataValue = Empty + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTREECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._Validate(ParentNode, "ParentNode", V_OBJECT) Then GoTo Catch + If ScriptForge.SF_Session.UnoObjectType(ParentNode) <> "toolkit.MutableTreeNode" Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(DisplayValue, "DisplayValue", V_STRING) Then GoTo Catch + End If + +Try: + With _TreeDataModel + Set oNode = .createNode(DisplayValue, True) + oNode.DataValue = DataValue + ParentNode.appendChild(oNode) + End With + +Finally: + Set AddSubNode = oNode + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "AddSubNode") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.AddSubNode + +REM ----------------------------------------------------------------------------- +Public Function AddSubTree(Optional ByRef ParentNode As Variant _ + , Optional ByRef FlatTree As Variant _ + , Optional ByVal WithDataValue As Variant _ + ) As Boolean +''' Return True when a subtree, subordinate to a parent node, could be inserted successfully in a tree control +''' If the parent node had already child nodes before calling this method, the child nodes are erased +''' Args: +''' ParentNode: A node UNO object, of type com.sun.star.awt.tree.XMutableTreeNode +''' FlatTree: a 2D array sorted on the columns containing the DisplayValues +''' Flat tree >>>> Resulting subtree +''' A1 B1 C1 |__ A1 +''' A1 B1 C2 |__ B1 +''' A1 B2 C3 |__ C1 +''' A2 B3 C4 |__ C2 +''' A2 B3 C5 |__ B2 +''' A3 B4 C6 |__ C3 +''' |__ A2 +''' |__ B3 +''' |__ C4 +''' |__ C5 +''' |__ A3 +''' |__ B4 +''' |__ C6 +''' Typically, such an array can be issued by the GetRows method applied on the SFDatabases.Database service +''' when an array item containing the text to be displayed is = "" or is empty/null, +''' no new subnode is created and the remainder of the row is skipped +''' When AddSubTree() is called from a Python script, FlatTree may be an array of arrays +''' WithDataValue: +''' When False (default), every column of FlatTree contains the text to be displayed in the tree control +''' When True, the texts to be displayed (DisplayValue) are in columns 0, 2, 4, ... +''' while the DataValues are in columns 1, 3, 5, ... +''' Returns: +''' True when successful +''' Examples: +''' Dim myTree As Object, theRoot As Object, oDb As Object, vData As Variant +''' Set myTree = myDialog.Controls("myTreeControl") +''' Set theRoot = myTree.CreateRoot("By product category") +''' Set oDb = CreateScriptService("SFDatabases.Database", "/home/.../mydatabase.odb") +''' vData = oDb.GetRows("SELECT [Category].[Name], [Category].[ID], [Product].[Name], [Product].[ID] " _ +''' & "FROM [Category], [Product] WHERE [Product].[CategoryID] = [Category].[ID] " _ +''' & "ORDER BY [Category].[Name], [Product].[Name]") +''' myTree.AddSubTree(theRoot, vData, WithDataValue := True) + +Dim bSubTree As Boolean ' Return value +Dim oNode As Object ' com.sun.star.awt.tree.XMutableTreeNode +Dim oNewNode As Object ' com.sun.star.awt.tree.XMutableTreeNode +Dim lChildCount As Long ' Number of children nodes of a parent node +Dim iStep As Integer ' 1 when WithDataValue = False, 2 otherwise +Dim iDims As Integer ' Number of dimensions of FlatTree +Dim lMin1 As Long ' Lower bound (rows) +Dim lMin2 As Long ' Lower bounds (cols) +Dim lMax1 As Long ' Upper bound (rows) +Dim lMax2 As Long ' Upper bounds (cols) +Dim vFlatItem As Variant ' A single FlatTree item: FlatTree(i, j) +Dim vFlatItem2 As Variant ' A single FlatTree item +Dim bChange As Boolean ' When True, the item in FlatTree is different from the item above +Dim sValue As String ' Alias for display values +Dim i As Long, j As Long +Const cstThisSub = "SFDialogs.DialogControl.AddSubTree" +Const cstSubArgs = "ParentNode, FlatTree, [WithDataValue=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSubTree = False + +Check: + If IsMissing(WithDataValue) Or IsEmpty(WithDataValue) Then WithDataValue = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTREECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._Validate(ParentNode, "ParentNode", V_OBJECT) Then GoTo Catch + If ScriptForge.SF_Session.UnoObjectType(ParentNode) <> "toolkit.MutableTreeNode" Then GoTo Catch + If Not ScriptForge.SF_Utils._ValidateArray(FlatTree, "FlatTree") Then GoTo Catch ' Dimensions checked below + If Not ScriptForge.SF_Utils._Validate(WithDataValue, "WithDataValue", V_BOOLEAN) Then GoTo Catch + End If + +Try: + With _TreeDataModel + ' Clean subtree + lChildCount = ParentNode.getChildCount() + For i = 1 To lChildCount + ParentNode.removeChildByIndex(0) ' This cleans all subtrees too + Next i + + ' Determine bounds + iDims = ScriptForge.SF_Array.CountDims(FlatTree) + Select Case iDims + Case -1, 0 : GoTo Catch + Case 1 ' Called probably from Python + lMin1 = LBound(FlatTree, 1) : lMax1 = UBound(FlatTree, 1) + If Not IsArray(FlatTree(0)) Then GoTo Catch + If UBound(FlatTree(0)) < LBound(FlatTree(0)) Then GoTo Catch ' No columns + lMin2 = LBound(FlatTree(0)) : lMax2 = UBound(FlatTree(0)) + Case 2 + lMin1 = LBound(FlatTree, 1) : lMax1 = UBound(FlatTree, 1) + lMin2 = LBound(FlatTree, 2) : lMax2 = UBound(FlatTree, 2) + Case Else : GoTo Catch + End Select + + ' Build a new subtree + iStep = Iif(WithDataValue, 2, 1) + For i = lMin1 To lMax1 + bChange = ( i = 0 ) + ' Restart from the parent node at each i-iteration + Set oNode = ParentNode + For j = lMin2 To lMax2 Step iStep ' Array columns + If iDims = 1 Then vFlatItem = FlatTree(i)(j) Else vFlatItem = FlatTree(i, j) + If vFlatItem = "" Or IsNull(vFlatItem) Or IsEmpty(vFlatItem) Then + Set oNode = Nothing + Exit For ' Exit j-loop + End If + If Not bChange Then + If iDims = 1 Then vFlatItem2 = FlatTree(i - 1)(j) Else vFlatItem2 = FlatTree(i - 1, j) + bChange = ( vFlatItem <> vFlatItem2 ) + End If + If bChange Then ' Create new subnode at tree depth = j + If VarType(vFlatItem) = V_STRING Then sValue = vFlatItem Else sValue = ScriptForge.SF_String.Represent(vFlatItem) + Set oNewNode = .createNode(sValue, True) + If WithDataValue Then + If iDims = 1 Then vFlatItem2 = FlatTree(i)(j + 1) Else vFlatItem2 = FlatTree(i, j + 1) + oNewNode.DataValue = vFlatItem2 + End If + oNode.appendChild(oNewNode) + Set oNode = oNewNode + Else + ' Position next current node on last child of actual current node + lChildCount = oNode.getChildCount() + If lChildCount > 0 Then Set oNode = oNode.getChildAt(lChildCount - 1) Else Set oNode = Nothing + End If + Next j + Next i + bSubTree = True + End With + +Finally: + AddSubTree = bSubTree + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "AddSubTree") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.AddSubTree + +REM ----------------------------------------------------------------------------- +Public Function CreateRoot(Optional ByVal DisplayValue As Variant _ + , Optional ByRef DataValue As Variant _ + ) As Variant +''' Return a new root node of the tree control. The new tree root is inserted below pre-existing root nodes +''' Args: +''' DisplayValue: the text appearing in the control box +''' DataValue: any value associated with the root node. Default = Empty +''' Returns: +''' The new root node as a UNO object of type com.sun.star.awt.tree.XMutableTreeNode +''' Examples: +''' Dim myTree As Object, myNode As Object +''' Set myTree = myDialog.Controls("myTreeControl") +''' Set myNode = myTree.CreateRoot("Tree starts here ...") + +Dim oRoot As Object ' Return value +Const cstThisSub = "SFDialogs.DialogControl.CreateRoot" +Const cstSubArgs = "DisplayValue, [DataValue=Empty]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oRoot = Nothing + +Check: + If IsMissing(DataValue) Then DataValue = Empty + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTREECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._Validate(DisplayValue, "DisplayValue", V_STRING) Then GoTo Catch + End If + +Try: + With _TreeDataModel + Set oRoot = .createNode(DisplayValue, True) + oRoot.DataValue = DataValue + .setRoot(oRoot) + ' To be visible, a root must have contained at least 1 child. Create a fictive one and erase it. + ' This behaviour does not seem related to the RootDisplayed property ?? + oRoot.appendChild(.createNode("Something", False)) + oRoot.removeChildByIndex(0) + End With + +Finally: + Set CreateRoot = oRoot + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "CreateRoot") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.CreateRoot + +REM ----------------------------------------------------------------------------- +Public Function FindNode(Optional ByVal DisplayValue As String _ + , Optional ByRef DataValue As Variant _ + , Optional ByVal CaseSensitive As Boolean _ + ) As Object +''' Traverses the tree and find recursively, starting from the root, a node meeting some criteria +''' Either (1 match is enough): +''' having its DisplayValue like DisplayValue +''' having its DataValue = DataValue +''' Comparisons may be or not case-sensitive +''' The first matching occurrence is returned +''' Args: +''' DisplayValue: the pattern to be matched +''' DataValue: a string, a numeric value or a date or Empty (if not applicable) +''' CaseSensitive: applicable on both criteria. Default = False +''' Returns: +''' The found node of type com.sun.star.awt.tree.XMutableTreeNode or Nothing if not found +''' Examples: +''' Dim myTree As Object, myNode As Object +''' Set myTree = myDialog.Controls("myTreeControl") +''' Set myNode = myTree.FindNode("*Sophie*", CaseSensitive := True) + + +Dim oNode As Object ' Return value +Const cstThisSub = "SFDialogs.DialogControl.FindNode" +Const cstSubArgs = "[DisplayValue=""""], [DataValue=Empty], [CaseSensitive=False]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + Set oNode = Nothing + +Check: + If IsMissing(DisplayValue) Or IsEmpty(DisplayValue) Then DisplayValue = "" + If IsMissing(DataValue) Then DataValue = Empty + If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTREECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._Validate(DisplayValue, "DisplayValue", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", ScriptForge.V_BOOLEAN) Then GoTo Catch + End If + +Try: + Set oNode = _FindNode(_TreeDataModel.getRoot(), DisplayValue, DataValue, CaseSensitive) + +Finally: + Set FindNode = oNode + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "FindNode") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.FindNode + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' If the property does not exist, returns Null +''' Exceptions: +''' see the exceptions of the individual properties +''' Examples: +''' myModel.GetProperty("MyProperty") + +Const cstThisSub = "SFDialogs.DialogControl.GetProperty" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.GetProperty + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list of public methods of the Model service as an array + + Methods = Array( _ + "AddSubNode" _ + , "AddSubTree" _ + , "CreateRoot" _ + , "FindNode" _ + , "SetFocus" _ + , "WriteLine" _ + ) + +End Function ' SFDialogs.SF_DialogControl.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the Timer class as an array + + Properties = Array( _ + "Cancel" _ + , "Caption" _ + , "ControlType" _ + , "CurrentNode" _ + , "Default" _ + , "Enabled" _ + , "Format" _ + , "ListCount" _ + , "ListIndex" _ + , "Locked" _ + , "MultiSelect" _ + , "Name" _ + , "OnActionPerformed" _ + , "OnAdjustmentValueChanged" _ + , "OnFocusGained" _ + , "OnFocusLost" _ + , "OnItemStateChanged" _ + , "OnKeyPressed" _ + , "OnKeyReleased" _ + , "OnMouseDragged" _ + , "OnMouseEntered" _ + , "OnMouseExited" _ + , "OnMouseMoved" _ + , "OnMousePressed" _ + , "OnMouseReleased" _ + , "OnNodeExpanded" _ + , "OnNodeSelected" _ + , "OnTextChanged" _ + , "Page" _ + , "Parent" _ + , "Picture" _ + , "RootNode" _ + , "RowSource" _ + , "Text" _ + , "TipText" _ + , "TripleState" _ + , "Value" _ + , "Visible" _ + , "XControlModel" _ + , "XControlView" _ + , "XGridColumnModel" _ + , "XGridDataModel" _ + , "XTreeDataModel" _ + ) + +End Function ' SFDialogs.SF_DialogControl.Properties + +REM ----------------------------------------------------------------------------- +Public Function SetFocus() As Boolean +''' Set the focus on the current Control instance +''' Probably called from after an event occurrence +''' Args: +''' Returns: +''' True if focusing is successful +''' Example: +''' Dim oDlg As Object, oControl As Object +''' Set oDlg = CreateScriptService(,, "myControl") ' Control stored in current document's standard library +''' Set oControl = oDlg.Controls("thisControl") +''' oControl.SetFocus() + +Dim bSetFocus As Boolean ' Return value +Const cstThisSub = "SFDialogs.DialogControl.SetFocus" +Const cstSubArgs = "" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSetFocus = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive() Then GoTo Finally + End If + +Try: + If Not IsNull(_ControlView) Then + _ControlView.setFocus() + bSetFocus = True + End If + +Finally: + SetFocus = bSetFocus + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFControls.SF_DialogControl.SetFocus + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "SFDialogs.DialogControl.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function SetTableData(Optional ByRef DataArray As Variant _ + , Optional ByRef Widths As Variant _ + , Optional ByRef Alignments As Variant _ + ) As Boolean +''' Fill a table control with the given data. Preexisting data is erased +''' The Basic IDE allows to define if the control has a row and/or a column header +''' When it is the case, the array in argument should contain those headers resp. in the first +''' column and/or in the first row +''' A column in the control shall be sortable when the data (headers excluded) in that column +''' is homogeneously filled either with numbers or with strings +''' Columns containing strings will be left-aligned, those with numbers will be right-aligned +''' Args: +''' DataArray: the set of data to display in the table control, including optional column/row headers +''' Is a 2D array in Basic, is a tuple of tuples when called from Python +''' Widths: the column's relative widths as a 1D array, each element corresponding with a column +''' If the array is shorter than the number of columns, the last value is kept for the next columns. +''' Example: +''' Widths := Array(1, 2) +''' means that the first column is half as wide as all the other columns +''' When the argument is absent, the columns are evenly spread over the control +''' Alignments: the column's horizontal alignment as a string with length = number of columns. +''' Possible characters are: +''' L(EFT), C(ENTER), R(IGHT) or space (default behaviour) +''' Returns: +''' True when successful +''' Examples: +''' Dim myTable As Object, bSet As Boolean, vData As Variant +''' Set myTable = myDialog.Controls("myTableControl") ' This control has only column headers +''' vData = Array("Col1", "Col2", "Col3") +''' vData = SF_Array.AppendRow(vData, Array(1, 2, 3)) +''' vData = SF_Array.AppendRow(vData, Array(4, 5, 6)) +''' vData = SF_Array.AppendRow(vData, Array(7, 8, 9)) +''' bSet = myTable.SetTableData(vData, Alignments := " C ") + +Dim bData As Boolean ' Return value +Dim iDims As Integer ' Number of dimensions of DataArray +Dim lMin1 As Long ' LBound1 of input array +Dim lMax1 As Long ' UBound1 of input array +Dim lMin2 As Long ' LBound2 of input array +Dim lMax2 As Long ' UBound2 of input array +Dim lControlWidth As Long ' Width of the table control +Dim lMinW As Long ' lBound of Widths +Dim lMaxW As Long ' UBound of vWidths +Dim lMinRow As Long ' Row index of effective data subarray +Dim lMinCol As Long ' Column index of effective data subarray +Dim vRowHeaders As Variant ' Array of row headers +Dim sRowHeader As String ' A single row header +Dim vColHeaders As Variant ' Array of column headers +Dim oColumn As Object ' com.sun.star.awt.grid.XGridColumn +Dim dWidth As Double ' A single item of Widths +Dim dRelativeWidth As Double ' Sum of Widths up to the number of columns +Dim dWidthFactor As Double ' Factor to apply to relative widths to get absolute column widths +Dim vDataRow As Variant ' A single row content in the tablecontrol +Dim vDataItem As Variant ' A single DataArray item +Dim sAlign As String ' Column's horizontal alignments (single chars: L, C, R, space) +Dim lAlign As Long ' com.sun.star.style.HorizontalAlignment.XXX +Dim i As Long, j As Long, k As Long + +Const cstRowHdrWidth = 12 ' Estimated width of the row header + +Const cstThisSub = "SFDialogs.DialogControl.SetTableData" +Const cstSubArgs = "DataArray, [Widths=Array(1)], [Alignments=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bData = False + +Check: + If IsMissing(Widths) Or IsEmpty(Widths) Then Widths = Array(1) + If IsMissing(Alignments) Or IsEmpty(Alignments) Then Alignments = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If _ControlType <> CTLTABLECONTROL Then GoTo CatchType + If Not ScriptForge.SF_Utils._ValidateArray(DataArray, "DataArray") Then GoTo Catch ' Dimensions are checked below + If Not ScriptForge.SF_Utils._ValidateArray(Widths, "Widths", 1, ScriptForge.V_NUMERIC, True) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Alignments, "Alignments", V_STRING) Then GoTo Catch + End If + +Try: + ' Erase any pre-existing data and columns + _GridDataModel.removeAllRows() + For i = _GridColumnModel.ColumnCount - 1 To 0 Step -1 + _GridColumnModel.removeColumn(i) + Next i + + ' LBounds, UBounds - Basic or Pytho + iDims = ScriptForge.SF_Array.CountDims(DataArray) + Select Case iDims + Case -1, 0 : GoTo Catch + Case 1 ' Called probably from Python + lMin1 = LBound(DataArray, 1) : lMax1 = UBound(DataArray, 1) + If Not IsArray(DataArray(0)) Then GoTo Catch + If UBound(DataArray(0)) < LBound(DataArray(0)) Then GoTo Catch ' No columns + lMin2 = LBound(DataArray(0)) : lMax2 = UBound(DataArray(0)) + Case 2 + lMin1 = LBound(DataArray, 1) : lMax1 = UBound(DataArray, 1) + lMin2 = LBound(DataArray, 2) : lMax2 = UBound(DataArray, 2) + Case Else : GoTo Catch + End Select + + ' Extract headers from data array + lMinW = LBound(Widths) : lMaxW = UBound(Widths) + With _ControlModel + If .ShowColumnHeader Then + lMinRow = lMin1 + 1 + If iDims = 1 Then + vColHeaders = DataArray(lMin1) + Else + vColHeaders = ScriptForge.SF_Array.ExtractRow(DataArray, lMin1) + End If + Else + lMinRow = lMin1 + vColHeaders = Array() + End If + If .ShowRowHeader Then + lMinCol = lMin2 + 1 + If iDims = 1 Then + vRowHeaders = Array() + ReDim vRowHeaders(lMin1 To lMax1) + For i = lMin1 To lMax1 + vRowHeaders(i) = DataArray(i)(lMin2) + Next i + Else + vRowHeaders = ScriptForge.SF_Array.ExtractColumn(DataArray, lMin2) + End If + Else + lMinCol = lMin2 + vRowHeaders = Array() + End If + End With + + ' Create the columns + For j = lMinCol To lMax2 + Set oColumn = _GridColumnModel.createColumn() + If _ControlModel.ShowColumnHeader Then oColumn.Title = vColHeaders(j) + _GridColumnModel.addColumn(oColumn) + Next j + ' Size the columns. Column sizing cannot be done before all the columns are added + If lMaxW >= lMinW Then ' There must be at least 1 width given as argument + ' Size the columns proportionally with their relative widths + dRelativeWidth = 0.0 + i = lMinW - 1 + ' Compute the sum of the relative widths + For j = 0 To lMax2 - lMinCol + i = i + 1 + If i >= lMinW And i <= lMaxW Then dRelativeWidth = dRelativeWidth + Widths(i) Else dRelativeWidth = dRelativeWidth + Widths(lMaxW) + Next j + ' Set absolute widths + If dRelativeWidth > 0.0 Then dWidthFactor = CDbl((_ControlModel.Width - cstRowHdrWidth) / dRelativeWidth) Else dWidthFactor = 1.0 + i = lMinW - 1 + For j = 0 To lMax2 - lMinCol + i = i + 1 + If i >= lMinW And i <= lMaxW Then dWidth = CDbl(Widths(i)) Else dWidth = CDbl(Widths(lMaxW)) + _GridColumnModel.Columns(j).ColumnWidth = CLng(dWidthFactor * dWidth) + Next j + Else + ' Size all columns evenly + For j = 0 To lMax2 - lMinCol + _GridColumnModel.Columns(j).ColumnWidth = (_ControlModel.Width - cstRowHdrWidth) / (lMax2 - lMonCol + 1) + Next j + End If + + ' Initialize the column alignment + If Len(Alignments) >= lMax2 - lMinCol + 1 Then sAlign = Alignments Else sAlign = Alignments & Space(lMax2 - lMinCol + 1 - Len(Alignments)) + + ' Feed the table with data and define/confirm the column alignment + vDataRow = Array() + For i = lMinRow To lMax1 + ReDim vDataRow(0 To lMax2 - lMinCol) + For j = lMinCol To lMax2 + If iDims = 1 Then vDataItem = DataArray(i)(j) Else vDataItem = DataArray(i, j) + If VarType(vDataItem) = V_STRING Then + ElseIf ScriptForge.SF_Utils._VarTypeExt(vDataItem) = ScriptForge.V_NUMERIC Then + Else + vDataItem = ScriptForge.SF_String.Represent(vDataItem) + End If + vDataRow(j - lMinCol) = vDataItem + ' Store alignment while processing the first row of the array + If i = lMinRow Then + k = j - lMinCol + 1 + If Mid(sAlign, k, 1) = " " Then Mid(sAlign, k, 1) = Iif(VarType(vDataItem) = V_STRING, "L", "R") + End If + Next j + If _ControlModel.ShowRowHeader Then sRowHeader = vRowHeaders(i) Else sRowHeader = "" + _GridDataModel.addRow(sRowHeader, vDataRow) + Next i + + ' Determine alignments of each column + For j = 0 To lMax2 - lMinCol + Select Case Mid(sAlign, j + 1, 1) + Case "L", " " : lAlign = com.sun.star.style.HorizontalAlignment.LEFT + Case "R" : lAlign = com.sun.star.style.HorizontalAlignment.RIGHT + Case "C" : lAlign = com.sun.star.style.HorizontalAlignment.CENTER + Case Else + End Select + _GridColumnModel.Columns(j).HorizontalAlign = lAlign + Next j + + bData = True + +Finally: + SetTableData = bData + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "SetTableData") + GoTo Finally +End Function ' SFDialogs.SF_DialogControl.SetTableData + +REM ----------------------------------------------------------------------------- +Public Function WriteLine(Optional ByVal Line As Variant) As Boolean +''' Add a new line to a multiline TextField control +''' Args: +''' Line: (default = "") the line to insert at the end of the text box +''' a newline character will be inserted before the line, if relevant +''' Returns: +''' True if insertion is successful +''' Exceptions +''' TEXTFIELDERROR Method applicable on multiline text fields only +''' Example: +''' Dim oDlg As Object, oControl As Object +''' Set oDlg = CreateScriptService(,, "myControl") ' Control stored in current document's standard library +''' Set oControl = oDlg.Controls("thisControl") +''' oControl.WriteLine("a new line") + +Dim bWriteLine As Boolean ' Return value +Dim lTextLength As Long ' Actual length of text in box +Dim oSelection As New com.sun.star.awt.Selection +Dim sNewLine As String ' Newline character(s) +Const cstThisSub = "SFDialogs.DialogControl.WriteLine" +Const cstSubArgs = "[Line=""""]" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bWriteLine = False + +Check: + If IsMissing(Line) Or IsEmpty(Line) Then Line = "" + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not [_Parent]._IsStillAlive() Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(Line, "Line", V_STRING) Then GoTo Finally + End If + If ControlType <> CTLTEXTFIELD Then GoTo CatchField + If _ControlModel.MultiLine = False Then GoTo CatchField + +Try: + _ControlModel.HardLineBreaks = True + sNewLine = ScriptForge.SF_String.sfNEWLINE + With _ControlView + lTextLength = Len(.getText()) + If lTextLength = 0 Then ' Text field is still empty + oSelection.Min = 0 : oSelection.Max = 0 + .setText(Line) + Else ' Put cursor at the end of the actual text + oSelection.Min = lTextLength : oSelection.Max = lTextLength + .insertText(oSelection, sNewLine & Line) + End If + ' Put the cursor at the end of the inserted text + oSelection.Max = oSelection.Max + Len(sNewLine) + Len(Line) + oSelection.Min = oSelection.Max + .setSelection(oSelection) + End With + bWriteLine = True + +Finally: + WriteLine = bWriteLine + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchField: + ScriptForge.SF_Exception.RaiseFatal(TEXTFIELDERROR, _Name, _DialogName) + GoTo Finally +End Function ' SFControls.SF_DialogControl.WriteLine + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _FindNode(ByRef poNode As Object _ + , ByVal psDisplayValue As String _ + , ByRef pvDataValue As Variant _ + , ByVal pbCaseSensitive As Boolean _ + ) As Object +''' Traverses the tree and find recursively, starting from the root, a node meeting some criteria +''' Either (1 match is enough): +''' having its DisplayValue like psDisplayValue +''' having its DataValue = pvDataValue +''' Comparisons may be or not case-sensitive +''' The first matching occurrence is returned +''' Args: +''' poNode: the current node, the root at 1st call +''' psDisplayValue: the pattern to be matched +''' pvDataValue: a string, a numeric value or a date or Empty (if not applicable) +''' pbCaseSensitive: applicable on both criteria +''' Returns: +''' The found node of type com.sun.star.awt.tree.XMutableTreeNode + +Dim oChild As Object ' Child node com.sun.star.awt.tree.XMutableTreeNode +Dim oFind As Object ' Found node com.sun.star.awt.tree.XMutableTreeNode +Dim lChildCount As Long ' Number of children of a node +Dim bFound As Boolean ' True when node found +Dim i As Long + + Set _FindNode = Nothing + On Local Error GoTo Finally ' Better not found than raise an error + +Check: + ' Does the actual node match the criteria ? + bFound = False + If Len(psDisplayValue) > 0 Then + bFound = ScriptForge.SF_String.IsLike(poNode.DisplayValue, psDisplayValue, pbCaseSensitive) + End If + If Not bFound And Not IsEmpty(poNode.DataValue) Then + If Not IsEmpty(pvdataValue) Then bFound = ( ScriptForge.SF_Array._ValCompare(poNode.DataValue, pvDataB-Value, pbCaseSensitive) = 0 ) + End If + If bFound Then + Set _FindNode = poNode + Exit Function + End If + +Try: + ' Explore sub-branches + lChildCount = poNode.getChildCount + If lChildCount > 0 Then + For i = 0 To lChildCount - 1 + Set oChild = poNode.getChildAt(i) + Set oFind = _FindNode(oChild, psDisplayValue, pvDataValue, pbCaseSensitive) ' Recursive call + If Not IsNull(oFind) Then + Set _FindNode = oFind + Exit For + End If + Next i + End If + +Finally: + Exit Function +End Function ' SFDialogs.SF_DialogControl._FindNode + +REM ----------------------------------------------------------------------------- +Private Function _FormatsList() As Variant +''' Return the allowed format entries as a zero-based array for Date and Time control types + +Dim vFormats() As Variant ' Return value + + Select Case _ControlType + Case CTLDATEFIELD + vFormats = Array( _ + "Standard (short)" _ + , "Standard (short YY)" _ + , "Standard (short YYYY)" _ + , "Standard (long)" _ + , "DD/MM/YY" _ + , "MM/DD/YY" _ + , "YY/MM/DD" _ + , "DD/MM/YYYY" _ + , "MM/DD/YYYY" _ + , "YYYY/MM/DD" _ + , "YY-MM-DD" _ + , "YYYY-MM-DD" _ + ) + Case CTLTIMEFIELD + vFormats = Array( _ + "24h short" _ + , "24h long" _ + , "12h short" _ + , "12h long" _ + ) + Case Else + vFormats = Array() + End Select + + _FormatsList = vFormats + +End Function ' SFDialogs.SF_DialogControl._FormatsList + +REM ----------------------------------------------------------------------------- +Public Function _GetEventName(ByVal psProperty As String) As String +''' Return the LO internal event name derived from the SF property name +''' The SF property name is not case sensitive, while the LO name is case-sensitive +' Corrects the typo on ErrorOccur(r?)ed, if necessary + +Dim vProperties As Variant ' Array of class properties +Dim sProperty As String ' Correctly cased property name + + vProperties = Properties() + sProperty = vProperties(ScriptForge.SF_Array.IndexOf(vProperties, psProperty, SortOrder := "ASC")) + + _GetEventName = LCase(Mid(sProperty, 3, 1)) & Right(sProperty, Len(sProperty) - 3) + +End Function ' SFDialogs.SF_DialogControl._GetEventName + +REM ----------------------------------------------------------------------------- +Private Function _GetListener(ByVal psEventName As String) As String +''' Getting/Setting macros triggered by events requires a Listener-EventName pair +''' Return the X...Listener corresponding with the event name in argument + + Select Case UCase(psEventName) + Case UCase("OnActionPerformed") + _GetListener = "XActionListener" + Case UCase("OnAdjustmentValueChanged") + _GetListener = "XAdjustmentListener" + Case UCase("OnFocusGained"), UCase("OnFocusLost") + _GetListener = "XFocusListener" + Case UCase("OnItemStateChanged") + _GetListener = "XItemListener" + Case UCase("OnKeyPressed"), UCase("OnKeyReleased") + _GetListener = "XKeyListener" + Case UCase("OnMouseDragged"), UCase("OnMouseMoved") + _GetListener = "XMouseMotionListener" + Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased") + _GetListener = "XMouseListener" + Case UCase("OnTextChanged") + _GetListener = "XTextListener" + Case Else + _GetListener = "" + End Select + +End Function ' SFDialogs.SF_DialogControl._GetListener + +REM ----------------------------------------------------------------------------- +Public Sub _Initialize() +''' Complete the object creation process: +''' - Initialization of private members +''' - Collection of specific attributes +''' - synchronization with parent dialog instance + +Dim vServiceName As Variant ' Split service name +Dim sType As String ' Last component of service name + +Try: + _ImplementationName = _ControlModel.getImplementationName() + + ' Identify the control type + vServiceName = Split(_ControlModel.getServiceName(), ".") + sType = vServiceName(UBound(vServiceName)) + Select Case sType + Case "UnoControlSpinButtonModel" + _ControlType = "" ' Not supported + Case "Edit" : _ControlType = CTLTEXTFIELD + Case "TreeControlModel" + ' Initialize the data model + _ControlType = CTLTREECONTROL + Set _ControlModel.DataModel = CreateUnoService("com.sun.star.awt.tree.MutableTreeDataModel") + Set _TreeDataModel = _ControlModel.DataModel + Case "UnoControlGridModel" + _ControlType = CTLTABLECONTROL + Set _GridColumnModel = _ControlModel.ColumnModel + Set _GridDataModel = _ControlModel.GridDataModel + Case Else : _ControlType = sType + End Select + + ' Store the SF_DialogControl object in the parent cache + Set _Parent._ControlCache(_IndexOfNames) = [Me] + +Finally: + Exit Sub +End Sub ' SFDialogs.SF_DialogControl._Initialize + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String _ + , Optional ByVal pvDefault As Variant _ + ) As Variant +''' Return the value of the named property +''' Args: +''' psProperty: the name of the property +''' pvDefault: the value returned when the property is not applicable on the control's type +''' Getting a non-existing property for a specific control type should +''' not generate an error to not disrupt the Basic IDE debugger + +Dim vGet As Variant ' Return value +Static oSession As Object ' Alias of SF_Session +Dim vSelection As Variant ' Alias of Model.SelectedItems or Model.Selection +Dim vList As Variant ' Alias of Model.StringItemList +Dim lIndex As Long ' Index in StringItemList +Dim sItem As String ' A single item +Dim vDate As Variant ' com.sun.star.util.Date or com.sun.star.util.Time +Dim vValues As Variant ' Array of listbox values +Dim oControlEvents As Object ' com.sun.star.container.XNameContainer +Dim sEventName As String ' Internal event name +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "" + + cstThisSub = "SFDialogs.DialogControl.get" & psProperty + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not [_Parent]._IsStillAlive() Then GoTo Finally + + If IsMissing(pvDefault) Then pvDefault = Null + _PropertyGet = pvDefault + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + Select Case UCase(psProperty) + Case UCase("Cancel") + Select Case _ControlType + Case CTLBUTTON + If oSession.HasUNOProperty(_ControlModel, "PushButtonType") Then _PropertyGet = ( _ControlModel.PushButtonType = com.sun.star.awt.PushButtonType.CANCEL ) + Case Else : GoTo CatchType + End Select + Case UCase("Caption") + Select Case _ControlType + Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDLINE, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON + If oSession.HasUNOProperty(_ControlModel, "Label") Then _PropertyGet = _ControlModel.Label + Case Else : GoTo CatchType + End Select + Case UCase("ControlType") + _PropertyGet = _ControlType + Case UCase("CurrentNode") + Select Case _ControlType + Case CTLTREECONTROL + If oSession.HasUNOMethod(_ControlView, "getSelection") Then + _PropertyGet = Empty + If _ControlModel.SelectionType <> com.sun.star.view.SelectionType.NONE Then + vSelection = _ControlView.getSelection() + If IsArray(vSelection) Then + If UBound(vSelection) >= 0 Then Set _PropertyGet = vSelection(0) + Else + Set _PropertyGet = vSelection + End If + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("Default") + Select Case _ControlType + Case CTLBUTTON + If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _PropertyGet = _ControlModel.DefaultButton + Case Else : GoTo CatchType + End Select + Case UCase("Enabled") + If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _PropertyGet = _ControlModel.Enabled + Case UCase("Format") + Select Case _ControlType + Case CTLDATEFIELD + If oSession.HasUNOProperty(_ControlModel, "DateFormat") Then _PropertyGet = _FormatsList()(_ControlModel.DateFormat) + Case CTLTIMEFIELD + If oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then _PropertyGet = _FormatsList()(_ControlModel.TimeFormat) + Case CTLFORMATTEDFIELD + If oSession.HasUNOProperty(_ControlModel, "FormatsSupplier") And oSession.HasUNOProperty(_ControlModel, "FormatKey") Then + _PropertyGet = _ControlModel.FormatsSupplier.getNumberFormats.getByKey(_ControlModel.FormatKey).FormatString + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListCount") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "StringItemList") Then _PropertyGet = UBound(_ControlModel.StringItemList) + 1 + Case CTLTABLECONTROL ' Returns zero when no table data yet + If oSession.HasUNOProperty(_GridDataModel, "RowCount") Then _PropertyGet = _GridDataModel.RowCount + Case Else : GoTo CatchType + End Select + Case UCase("ListIndex") + Select Case _ControlType + Case CTLCOMBOBOX + _PropertyGet = -1 ' Not found, multiselection + If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + _PropertyGet = ScriptForge.SF_Array.IndexOf(_ControlModel.StringItemList, _ControlModel.Text, CaseSensitive := True) + End If + Case CTLLISTBOX + _PropertyGet = -1 ' Not found, multiselection + If oSession.HasUNOProperty(_ControlModel, "SelectedItems") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + vSelection = _ControlModel.SelectedItems + If UBound(vSelection) >= 0 Then _PropertyGet = vSelection(0) + End If + Case CTLTABLECONTROL + _PropertyGet = -1 ' No row selected, no data, multiselection + If oSession.HasUNOProperty(_ControlModel, "SelectionModel") _ + And oSession.HasUNOProperty(_ControlView, "CurrentRow") Then + ' Other selection types (multi, range) not supported + If _ControlModel.SelectionModel = com.sun.star.view.SelectionType.SINGLE Then + lIndex = _ControlView.CurrentRow + If lIndex < 0 And oSession.HasUNOProperty(_ControlView, "SelectedRows") Then + If UBound(_ControlView.SelectedRows) >= 0 Then lIndex = _ControlView.SelectedRows(0) + End If + _PropertyGet = lIndex + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("Locked") + Select Case _ControlType + Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLLISTBOX _ + , CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD + If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _PropertyGet = _ControlModel.ReadOnly + Case Else : GoTo CatchType + End Select + Case UCase("MultiSelect") + Select Case _ControlType + Case CTLLISTBOX + If oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + _PropertyGet = _ControlModel.MultiSelection + ElseIf oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then ' Not documented: gridcontrols only TBC ?? + _PropertyGet = _ControlModel.MultiSelectionSimpleMode + End If + Case Else : GoTo CatchType + End Select + Case UCase("Name") + _PropertyGet = _Name + Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnFocusGained"), UCase("OnFocusLost") _ + , UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ + , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ + , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnTextChanged") + Set oControlEvents = _ControlModel.getEvents() + sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & _GetEventName(psProperty) + If oControlEvents.hasByName(sEventName) Then + _PropertyGet = oControlEvents.getByName(sEventName).ScriptCode + Else + _PropertyGet = "" + End If + Case UCase("OnNodeExpanded") + Select Case _ControlType + Case CTLTREECONTROL + _PropertyGet = _OnNodeExpanded + Case Else : GoTo CatchType + End Select + Case UCase("OnNodeSelected") + Select Case _ControlType + Case CTLTREECONTROL + _PropertyGet = _OnNodeSelected + Case Else : GoTo CatchType + End Select + Case UCase("Page") + If oSession.HasUnoProperty(_ControlModel, "Step") Then _PropertyGet = _ControlModel.Step + Case UCase("Parent") + Set _PropertyGet = [_Parent] + Case UCase("Picture") + Select Case _ControlType + Case CTLBUTTON, CTLIMAGECONTROL + If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _PropertyGet = ScriptForge.SF_FileSystem._ConvertFromUrl(_ControlModel.ImageURL) + Case Else : GoTo CatchType + End Select + Case UCase("RootNode") + Select Case _ControlType + Case CTLTREECONTROL + _PropertyGet = _TreeDataModel.getRoot() + Case Else : GoTo CatchType + End Select + Case UCase("RowSource") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If oSession.HasUnoProperty(_ControlModel, "StringItemList") Then + If IsArray(_ControlModel.StringItemList) Then _PropertyGet = _ControlModel.StringItemList Else _PropertyGet = Array(_ControlModel.StringItemList) + End If + Case Else : GoTo CatchType + End Select + Case UCase("Text") + Select Case _ControlType + Case CTLCOMBOBOX, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLPATTERNFIELD, CTLTEXTFIELD + If oSession.HasUnoProperty(_ControlModel, "Text") Then _PropertyGet = _ControlModel.Text + Case Else : GoTo CatchType + End Select + Case UCase("TipText") + If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _PropertyGet = _ControlModel.HelpText + Case UCase("TripleState") + Select Case _ControlType + Case CTLCHECKBOX + If oSession.HasUnoProperty(_ControlModel, "TriState") Then _PropertyGet = _ControlModel.TriState + Case Else : GoTo CatchType + End Select + Case UCase("Value") ' Default values are set here by control type, not in the 2nd argument + vGet = pvDefault + Select Case _ControlType + Case CTLBUTTON 'Boolean, toggle buttons only + vGet = False + If oSession.HasUnoProperty(_ControlModel, "Toggle") Then + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 ) + End If + Case CTLCHECKBOX '0 = Not checked, 1 = Checked, 2 = Don't know + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = _ControlModel.State Else vGet = 2 + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD 'String + If oSession.HasUnoProperty(_ControlModel, "Text") Then vGet = _ControlModel.Text Else vGet = "" + Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric + If oSession.HasUnoProperty(_ControlModel, "Value") Then vGet = _ControlModel.Value Else vGet = 0 + Case CTLDATEFIELD 'Date + vGet = CDate(1) + If oSession.HasUnoProperty(_ControlModel, "Date") Then + If VarType(_ControlModel.Date) = ScriptForge.V_OBJECT Then ' com.sun.star.util.Date + Set vDate = _ControlModel.Date + vGet = DateSerial(vDate.Year, vDate.Month, vDate.Day) + End If + End If + Case CTLFORMATTEDFIELD 'String or numeric + If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then vGet = _ControlModel.EffectiveValue Else vGet = "" + Case CTLLISTBOX 'String or array of strings depending on MultiSelection + ' StringItemList is the list of the items displayed in the box + ' SelectedItems is the list of the indexes in StringItemList of the selected items + ' It can go beyond the limits of StringItemList + ' It can contain multiple values even if the listbox is not multiselect + If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") _ + And oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + vSelection = _ControlModel.SelectedItems + vList = _ControlModel.StringItemList + If _ControlModel.MultiSelection Then vValues = Array() + For i = 0 To UBound(vSelection) + lIndex = vSelection(i) + If lIndex >= 0 And lIndex <= UBound(vList) Then + If Not _ControlModel.MultiSelection Then + vValues = vList(lIndex) + Exit For + End If + vValues = ScriptForge.SF_Array.Append(vValues, vList(lIndex)) + End If + Next i + vGet = vValues + Else + vGet = "" + End If + Case CTLPROGRESSBAR 'Numeric + If oSession.HasUnoProperty(_ControlModel, "ProgressValue") Then vGet = _ControlModel.ProgressValue Else vGet = 0 + Case CTLRADIOBUTTON 'Boolean + If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 ) Else vGet = False + Case CTLSCROLLBAR 'Numeric + If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then vGet = _ControlModel.ScrollValue Else vGet = 0 + Case CTLTABLECONTROL + vGet = Array() ' Default value when no row selected, no data, multiselection + If oSession.HasUNOProperty(_ControlModel, "SelectionModel") _ + And oSession.HasUNOProperty(_ControlView, "CurrentRow") Then + ' Other selection types (multi, range) not supported + If _ControlModel.SelectionModel = com.sun.star.view.SelectionType.SINGLE Then + lIndex = _ControlView.CurrentRow + If lIndex < 0 And oSession.HasUNOProperty(_ControlView, "SelectedRows") Then + If UBound(_ControlView.SelectedRows) >= 0 Then lIndex = _ControlView.SelectedRows(0) + End If + If lIndex >= 0 Then vGet = _GridDataModel.getRowData(lIndex) + End If + End If + Case CTLTIMEFIELD + vGet = CDate(0) + If oSession.HasUnoProperty(_ControlModel, "Time") Then + If VarType(_ControlModel.Time) = ScriptForge.V_OBJECT Then ' com.sun.star.Util.Time + Set vDate = _ControlModel.Time + vGet = TimeSerial(vDate.Hours, vDate.Minutes, vDate.Seconds) + End If + End If + Case Else : GoTo CatchType + End Select + _PropertyGet = vGet + Case UCase("Visible") + If oSession.HasUnoMethod(_ControlView, "isVisible") Then _PropertyGet = CBool(_ControlView.isVisible()) + Case UCase("XControlModel") + Set _PropertyGet = _ControlModel + Case UCase("XControlView") + Set _PropertyGet = _ControlView + Case UCase("XGridColumnModel") + Set _PropertyGet = _GridColumnModel + Case UCase("XGridDataModel") + Set _PropertyGet = _GridDataModel + Case UCase("XTreeDataModel") + Set _PropertyGet = _TreeDataModel + Case Else + _PropertyGet = Null + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + GoTo Finally +End Function ' SFDialogs.SF_DialogControl._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property + +Dim bSet As Boolean ' Return value +Static oSession As Object ' Alias of SF_Session +Dim vSet As Variant ' Value to set in UNO model or view property +Dim vFormats As Variant ' Format property: output of _FormatsList() +Dim iFormat As Integer ' Format property: index in vFormats +Dim vSelection As Variant ' Alias of Model.SelectedItems +Dim vList As Variant ' Alias of Model.StringItemList +Dim lIndex As Long ' Index in StringItemList +Dim sItem As String ' A single item +Dim vCtlTypes As Variant ' Array of allowed control types +Dim i As Long +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFDialogs.DialogControl.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + If Not [_Parent]._IsStillAlive() Then GoTo Finally + + If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session") + bSet = True + Select Case UCase(psProperty) + Case UCase("Cancel") + Select Case _ControlType + Case CTLBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Cancel", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "PushButtonType") Then + If pvValue Then vSet = com.sun.star.awt.PushButtonType.CANCEL Else vSet = com.sun.star.awt.PushButtonType.STANDARD + _ControlModel.PushButtonType = vSet + End If + Case Else : GoTo CatchType + End Select + Case UCase("Caption") + Select Case _ControlType + Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDLINE, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Caption", V_STRING) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "Label") Then _ControlModel.Label = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("CurrentNode") + Select Case _ControlType + Case CTLTREECONTROL + If Not ScriptForge.SF_Utils._Validate(pvValue, "Selection", ScriptForge.V_OBJECT) Then GoTo Finally + If oSession.UnoObjectType(pvValue) <> "toolkit.MutableTreeNode" Then GoTo CatchType + With _ControlView + .clearSelection() + If Not IsNull(pvValue) Then + .addSelection(pvValue) + ' Suspending temporarily the expansion listener avoids conflicts + If Len(_OnNodeExpanded) > 0 Then _ControlView.removeTreeExpansionListener(_ExpandListener) + .makeNodeVisible(pvValue) ' Expand parent nodes and put node in the display area + If Len(_OnNodeExpanded) > 0 Then _ControlView.addTreeExpansionListener(_ExpandListener) + End If + End With + Case Else : GoTo CatchType + End Select + Case UCase("Default") + Select Case _ControlType + Case CTLBUTTON + If Not ScriptForge.SF_Utils._Validate(pvValue, "Default", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _ControlModel.DefaultButton = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Enabled") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Enabled", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _ControlModel.Enabled = pvValue + Case UCase("Format") + Select Case _ControlType + Case CTLDATEFIELD, CTLTIMEFIELD + vFormats = _FormatsList() + If Not ScriptForge.SF_Utils._Validate(pvValue, "Format", V_STRING, vFormats) Then GoTo Finally + iFormat = ScriptForge.SF_Array.IndexOf(vFormats, pvValue, CaseSensitive := False) + If oSession.HasUNOProperty(_ControlModel, "DateFormat") Then + _ControlModel.DateFormat = iFormat + ElseIf oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then + _ControlModel.TimeFormat = iFormat + End If + Case Else : GoTo CatchType + End Select + Case UCase("ListIndex") + If Not ScriptForge.SF_Utils._Validate(pvValue, "ListIndex", ScriptForge.V_NUMERIC) Then GoTo Finally + Select Case _ControlType + Case CTLCOMBOBOX + If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then + _ControlModel.Text = _ControlModel.StringItemList(CInt(pvValue)) + End If + Case CTLLISTBOX + If oSession.HasUNOProperty(_ControlModel, "SelectedItems") Then _ControlModel.SelectedItems = Array(CInt(pvValue)) + Case CTLTABLECONTROL + If oSession.HasUNOProperty(_ControlModel, "SelectionModel") _ + And oSession.HasUNOMethod(_ControlView, "selectRow") Then + ' Other selection types (multi, range) not supported + If _ControlModel.SelectionModel = com.sun.star.view.SelectionType.SINGLE _ + And pvValue >= 0 And pvValue <= _GridDataModel.RowCount - 1 Then + _ControlView.selectRow(pvValue) + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("Locked") + Select Case _ControlType + Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLLISTBOX _ + , CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD + If Not ScriptForge.SF_Utils._Validate(pvValue, "Locked", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _ControlModel.ReadOnly = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("MultiSelect") + Select Case _ControlType + Case CTLLISTBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "MultiSelect", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then _ControlModel.MultiSelection = pvValue + If oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then _ControlModel.MultiSelectionSimpleMode = pvValue + If oSession.HasUnoProperty(_ControlModel, "SelectedItems") Then + If Not pvValue And UBound(_ControlModel.SelectedItems) > 0 Then ' Cancel selections when MultiSelect becomes False + lIndex = _ControlModel.SelectedItems(0) + _ControlModel.SelectedItems = Array(lIndex) + End If + End If + Case Else : GoTo CatchType + End Select + Case UCase("OnNodeExpanded") + Select Case _ControlType + Case CTLTREECONTROL + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then GoTo Finally + ' If the listener was already set, then stop it + If Len(_OnNodeExpanded) > 0 Then + _ControlView.removeTreeExpansionListener(_ExpandListener) + Set _ExpandListener = Nothing + _OnNodeExpanded = "" + End If + ' Setup a new fresh listener + If Len(pvValue) > 0 Then + Set _ExpandListener = CreateUnoListener("_SFEXP_", "com.sun.star.awt.tree.XTreeExpansionListener") + _ControlView.addTreeExpansionListener(_ExpandListener) + _OnNodeExpanded = pvValue + End If + Case Else : GoTo CatchType + End Select + Case UCase("OnNodeSelected") + Select Case _ControlType + Case CTLTREECONTROL + If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then GoTo Finally + ' If the listener was already set, then stop it + If Len(_OnNodeSelected) > 0 Then + _ControlView.removeSelectionChangeListener(_SelectListener) + Set _SelectListener = Nothing + _OnNodeSelected = "" + End If + ' Setup a new fresh listener + If Len(pvValue) > 0 Then + Set _SelectListener = CreateUnoListener("_SFSEL_", "com.sun.star.view.XSelectionChangeListener") + _ControlView.addSelectionChangeListener(_SelectListener) + _OnNodeSelected = pvValue + End If + Case Else : GoTo CatchType + End Select + Case UCase("Page") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Page", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Step") Then _ControlModel.Step = CLng(pvValue) + Case UCase("Picture") + Select Case _ControlType + Case CTLBUTTON, CTLIMAGECONTROL + If Not ScriptForge.SF_Utils._ValidateFile(pvValue, "Picture") Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _ControlModel.ImageURL = ScriptForge.SF_FileSystem._ConvertToUrl(pvValue) + Case Else : GoTo CatchType + End Select + Case UCase("RowSource") + Select Case _ControlType + Case CTLCOMBOBOX, CTLLISTBOX + If Not IsArray(pvValue) Then + If Not ScriptForge.SF_Utils._Validate(pvValue, "RowSource", V_STRING) Then GoTo Finally + pvArray = Array(pvArray) + ElseIf Not ScriptForge.SF_Utils._ValidateArray(pvValue, "RowSource", 1, V_STRING, True) Then + GoTo Finally + End If + If oSession.HasUnoProperty(_ControlModel, "StringItemList") Then _ControlModel.StringItemList = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("TipText") + If Not ScriptForge.SF_Utils._Validate(pvValue, "TipText", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _ControlModel.HelpText = pvValue + Case UCase("TripleState") + Select Case _ControlType + Case CTLCHECKBOX + If Not ScriptForge.SF_Utils._Validate(pvValue, "TripleState", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "TriState") Then _ControlModel.TriState = pvValue + Case Else : GoTo CatchType + End Select + Case UCase("Value") + Select Case _ControlType + Case CTLBUTTON 'Boolean, toggle buttons only + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Toggle") And oSession.HasUnoProperty(_ControlModel, "State") Then + _ControlModel.State = Iif(pvValue, 1, 0) + End If + Case CTLCHECKBOX '0 = Not checked, 1 = Checked, 2 = Don't know + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(ScriptForge.V_BOOLEAN, ScriptForge.V_NUMERIC), Array(0, 1, 2, True, False)) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "State") Then + If VarType(pvValue) = ScriptForge.V_BOOLEAN Then pvValue = Iif(pvValue, 1, 0) + _ControlModel.State = pvValue + End If + Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD 'String + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Text") Then _ControlModel.Text = pvValue + Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Value") Then _ControlModel.Value = pvValue + Case CTLDATEFIELD 'Date + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_DATE) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Date") Then + Set vSet = New com.sun.star.util.Date + vSet.Year = Year(pvValue) + vSet.Month = Month(pvValue) + vSet.Day = Day(pvValue) + _ControlModel.Date = vSet + End If + Case CTLFORMATTEDFIELD 'String or numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then _ControlModel.EffectiveValue = pvValue + Case CTLLISTBOX 'String or array of strings depending on MultiSelection + ' StringItemList is the list of the items displayed in the box + ' SelectedItems is the list of the indexes in StringItemList of the selected items + ' It can go beyond the limits of StringItemList + ' It can contain multiple values even if the listbox is not multiselect + If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") _ + And oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then + vSelection = Array() + If _ControlModel.MultiSelection Then + If Not ScriptForge.SF_Utils._ValidateArray(pvValue, "Value", 1, V_STRING, True) Then GoTo Finally + vList = _ControlModel.StringItemList + For i = LBound(pvValue) To UBound(pvValue) + sItem = pvValue(i) + lIndex = ScriptForge.SF_Array.IndexOf(vList, sItem) + If lIndex >= 0 Then vSelection = ScriptForge.SF_Array.Append(vSelection, lIndex) + Next i + Else + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_STRING) Then GoTo Finally + lIndex = ScriptForge.SF_Array.IndexOf(_ControlModel.StringItemList, pvValue) + If lIndex >= 0 Then vSelection = Array(lIndex) + End If + _ControlModel.SelectedItems = vSelection + End If + Case CTLPROGRESSBAR 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ProgressValueMin") Then + If pvValue < _ControlModel.ProgressValueMin Then pvValue = _ControlModel.ProgressValueMin + End If + If oSession.HasUnoProperty(_ControlModel, "ProgressValueMax") Then + If pvValue > _ControlModel.ProgressValueMax Then pvValue = _ControlModel.ProgressValueMax + End If + If oSession.HasUnoProperty(_ControlModel, "ProgressValue") Then _ControlModel.ProgressValue = pvValue + Case CTLRADIOBUTTON 'Boolean + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "State") Then _ControlModel.State = Iif(pvValue, 1, 0) + Case CTLSCROLLBAR 'Numeric + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "ScrollValueMin") Then + If pvValue < _ControlModel.ScrollValueMin Then pvValue = _ControlModel.ScrollValueMin + End If + If oSession.HasUnoProperty(_ControlModel, "ScrollValueMax") Then + If pvValue > _ControlModel.ScrollValueMax Then pvValue = _ControlModel.ScrollValueMax + End If + If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then _ControlModel.ScrollValue = pvValue + Case CTLTIMEFIELD + If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", V_DATE) Then GoTo Finally + If oSession.HasUnoProperty(_ControlModel, "Time") Then + Set vSet = New com.sun.star.util.Time + vSet.Hours = Hour(pvValue) + vSet.Minutes = Minute(pvValue) + vSet.Seconds = Second(pvValue) + _ControlModel.Time = vSet + End If + Case Else : GoTo CatchType + End Select + Case UCase("Visible") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Visible", ScriptForge.V_BOOLEAN) Then GoTo Finally + If oSession.HasUnoMethod(_ControlView, "setVisible") Then + If pvValue Then + If oSession.HasUnoProperty(_ControlModel, "EnableVisible") Then _ControlModel.EnableVisible = True + End If + _ControlView.setVisible(pvValue) + End If + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +CatchType: + ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, psProperty) + GoTo Finally +End Function ' SFDialogs.SF_DialogControl._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the Model instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[DIALOGCONTROL]: Name, Type (dialogname) + _Repr = "[DIALOGCONTROL]: " & _Name & ", " & _ControlType & " (" & _DialogName & ")" + +End Function ' SFDialogs.SF_DialogControl._Repr + +REM ============================================ END OF SFDIALOGS.SF_DIALOGCONTROL +</script:module>
\ No newline at end of file |