Linux ns1.utparral.edu.mx 6.8.0-79-generic #79~22.04.1-Ubuntu SMP PREEMPT_DYNAMIC Fri Aug 15 16:54:53 UTC 2 x86_64
Apache/2.4.58 (Unix) OpenSSL/1.1.1w PHP/8.2.12 mod_perl/2.0.12 Perl/v5.34.1
: 10.10.1.9 | : 10.10.1.254
Cant Read [ /etc/named.conf ]
daemon
Terminal
AUTO ROOT
Adminer
Backdoor Destroyer
Linux Exploit
Lock Shell
Lock File
Create User
README
+ Create Folder
+ Create File
/
usr /
lib /
libreoffice /
share /
basic /
SFDialogs /
[ HOME SHELL ]
Name
Size
Permission
Action
dialog.xlb
288
B
-rw-r--r--
__License.xba
1.77
KB
-rw-r--r--
script.xlb
548
B
-rw-r--r--
SF_DialogControl.xba
99.78
KB
-rw-r--r--
SF_DialogListener.xba
5.59
KB
-rw-r--r--
SF_Dialog.xba
39.45
KB
-rw-r--r--
SF_Register.xba
16.41
KB
-rw-r--r--
Delete
Unzip
Zip
${this.title}
Close
Code Editor : SF_DialogControl.xba
<?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>
Close