| blob | f4a0891d92c435defc1a9585c3d48d2b46e04212 |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_DialogControl" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
4 REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
5 REM === The SFDialogs library is one of the associated libraries. ===
6 REM === Full documentation is available on https://help.libreoffice.org/ ===
7 REM =======================================================================================================================
9 Option Compatible
10 Option ClassModule
12 Option Explicit
14 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
15 ''' SF_DialogControl
16 ''' ================
17 ''' Manage the controls belonging to a dialog defined with the Basic IDE
18 ''' Each instance of the current class represents a single control within a dialog box
19 '''
20 ''' The focus is clearly set on getting and setting the values displayed by the controls of the dialog box,
21 ''' not on their formatting. The latter is easily accessible via the XControlModel and XControlView
22 ''' UNO objects.
23 ''' Essentially a single property "Value" maps many alternative UNO properties depending each on
24 ''' the control type.
25 '''
26 ''' A special attention is given to controls with types TreeControl and TableControl
27 ''' It is easy with the API proposed in the current class to populate a tree, either
28 ''' - branch by branch (CreateRoot and AddSubNode), or
29 ''' - with a set of branches at once (AddSubtree)
30 ''' Additionally populating a TreeControl can be done statically or dynamically
31 '''
32 ''' With the method SetTableData(), feed a tablecontrol with a sortable and selectable
33 ''' array of data. Columns and rows may receive a header. Column widths are adjusted manually by the user or
34 ''' with the same method. Alignments can be set as well by script.
35 '''
36 ''' Service invocation:
37 ''' Dim myDialog As Object, myControl As Object
38 ''' Set myDialog = CreateScriptService("SFDialogs.Dialog", "GlobalScope", myLibrary, DialogName)
41 ''' myDialog.Execute()
42 ''' ' ... process the controls actual values
43 ''' myDialog.Terminate()
44 '''
45 ''' Detailed user documentation:
46 ''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_dialogcontrol.html?DbPAR=BASIC
47 '''
48 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
50 REM ================================================================== EXCEPTIONS
55 REM ============================================================= PRIVATE MEMBERS
57 Private [Me] As Object
58 Private [_Parent] As Object
59 Private ObjectType As String ' Must be DIALOGCONTROL
60 Private ServiceName As String
62 ' Control naming
63 Private _Name As String
64 Private _IndexOfNames As Long ' Index in ElementNames array. Used to access SF_Dialog._ControlCache
65 Private _DialogName As String ' Parent dialog name
67 ' Control UNO references
68 Private _ControlModel As Object ' com.sun.star.awt.XControlModel
69 Private _ControlView As Object ' com.sun.star.awt.XControl - stardiv.Toolkit.UnoDialogControl
70 Private _TreeDataModel As Object ' com.sun.star.awt.tree.MutableTreeDataModel
71 Private _GridColumnModel As Object ' com.sun.star.awt.grid.XGridColumnModel
72 Private _GridDataModel As Object ' com.sun.star.awt.grid.XGridDataModel
74 ' Control attributes
75 Private _ImplementationName As String
76 Private _ControlType As String ' One of the CTLxxx constants
78 ' Tree control on-select and on-expand attributes
79 ' Tree controls may be associated with events not defined in the Basic IDE
80 Private _OnNodeSelected As String ' Script to invoke when a node is selected
81 Private _OnNodeExpanded As String ' Script to invoke when a node is expanded
82 Private _SelectListener As Object ' com.sun.star.view.XSelectionChangeListener
83 Private _ExpandListener As Object ' com.sun.star.awt.tree.XTreeExpansionListener
85 ' Table control attributes
86 Private _ColumnWidths As Variant ' Array of column widths
88 REM ============================================================ MODULE CONSTANTS
112 REM ====================================================== CONSTRUCTOR/DESTRUCTOR
114 REM -----------------------------------------------------------------------------
115 Private Sub Class_Initialize()
116 Set [Me] = Nothing
117 Set [_Parent] = Nothing
120 _Name = ""
121 _IndexOfNames = -1
122 _DialogName = ""
123 Set _ControlModel = Nothing
124 Set _ControlView = Nothing
125 Set _TreeDataModel = Nothing
126 Set _GridColumnModel = Nothing
127 Set _GridDataModel = Nothing
128 _ImplementationName = ""
129 _ControlType = ""
130 _OnNodeSelected = ""
131 _OnNodeExpanded = ""
132 Set _SelectListener = Nothing
133 Set _ExpandListener = Nothing
134 _ColumnWidths = Array()
135 End Sub ' SFDialogs.SF_DialogControl Constructor
137 REM -----------------------------------------------------------------------------
138 Private Sub Class_Terminate()
139 Call Class_Initialize()
140 End Sub ' SFDialogs.SF_DialogControl Destructor
142 REM -----------------------------------------------------------------------------
143 Public Function Dispose() As Variant
144 Call Class_Terminate()
145 Set Dispose = Nothing
146 End Function ' SFDialogs.SF_DialogControl Explicit Destructor
148 REM ================================================================== PROPERTIES
150 REM -----------------------------------------------------------------------------
151 Property Get Cancel() As Variant
152 ''' The Cancel property specifies if a command button has or not the behaviour of a Cancel button.
154 End Property ' SFDialogs.SF_DialogControl.Cancel (get)
156 REM -----------------------------------------------------------------------------
157 Property Let Cancel(Optional ByVal pvCancel As Variant)
158 ''' Set the updatable property Cancel
160 End Property ' SFDialogs.SF_DialogControl.Cancel (let)
162 REM -----------------------------------------------------------------------------
163 Property Get Caption() As Variant
164 ''' The Caption property refers to the text associated with the control
166 End Property ' SFDialogs.SF_DialogControl.Caption (get)
168 REM -----------------------------------------------------------------------------
169 Property Let Caption(Optional ByVal pvCaption As Variant)
170 ''' Set the updatable property Caption
172 End Property ' SFDialogs.SF_DialogControl.Caption (let)
174 REM -----------------------------------------------------------------------------
175 Property Get ControlType() As String
176 ''' Return the type of the actual control: "CheckBox", "TextField", "DateField", ...
178 End Property ' SFDialogs.SF_DialogControl.ControlType
180 REM -----------------------------------------------------------------------------
181 Property Get CurrentNode() As Variant
182 ''' The CurrentNode property returns the currently selected node
183 ''' It returns Empty when there is no node selected
184 ''' When there are several selections, it returns the topmost node among the selected ones
186 End Property ' SFDialogs.SF_DialogControl.CurrentNode (get)
188 REM -----------------------------------------------------------------------------
189 Property Let CurrentNode(Optional ByVal pvCurrentNode As Variant)
190 ''' Set a single selection in a tree control
192 End Property ' SFDialogs.SF_DialogControl.CurrentNode (let)
194 REM -----------------------------------------------------------------------------
195 Property Get Default() As Variant
196 ''' The Default property specifies whether a command button is the default (OK) button.
198 End Property ' SFDialogs.SF_DialogControl.Default (get)
200 REM -----------------------------------------------------------------------------
201 Property Let Default(Optional ByVal pvDefault As Variant)
202 ''' Set the updatable property Default
204 End Property ' SFDialogs.SF_DialogControl.Default (let)
206 REM -----------------------------------------------------------------------------
207 Property Get Enabled() As Variant
208 ''' The Enabled property specifies if the control is accessible with the cursor.
210 End Property ' SFDialogs.SF_DialogControl.Enabled (get)
212 REM -----------------------------------------------------------------------------
213 Property Let Enabled(Optional ByVal pvEnabled As Variant)
214 ''' Set the updatable property Enabled
216 End Property ' SFDialogs.SF_DialogControl.Enabled (let)
218 REM -----------------------------------------------------------------------------
219 Property Get Format() As Variant
220 ''' The Format property specifies the format in which to display dates and times.
222 End Property ' SFDialogs.SF_DialogControl.Format (get)
224 REM -----------------------------------------------------------------------------
225 Property Let Format(Optional ByVal pvFormat As Variant)
226 ''' Set the updatable property Format
227 ''' NB: Format is read-only for formatted field controls
229 End Property ' SFDialogs.SF_DialogControl.Format (let)
231 REM -----------------------------------------------------------------------------
232 Property Get ListCount() As Long
233 ''' The ListCount property specifies the number of rows in a list box or a combo box
235 End Property ' SFDialogs.SF_DialogControl.ListCount (get)
237 REM -----------------------------------------------------------------------------
238 Property Get ListIndex() As Variant
239 ''' The ListIndex property specifies which item is selected in a list box or combo box.
240 ''' In case of multiple selection, the index of the first one is returned or only one is set
242 End Property ' SFDialogs.SF_DialogControl.ListIndex (get)
244 REM -----------------------------------------------------------------------------
245 Property Let ListIndex(Optional ByVal pvListIndex As Variant)
246 ''' Set the updatable property ListIndex
248 End Property ' SFDialogs.SF_DialogControl.ListIndex (let)
250 REM -----------------------------------------------------------------------------
251 Property Get Locked() As Variant
252 ''' The Locked property specifies if a control is read-only
254 End Property ' SFDialogs.SF_DialogControl.Locked (get)
256 REM -----------------------------------------------------------------------------
257 Property Let Locked(Optional ByVal pvLocked As Variant)
258 ''' Set the updatable property Locked
260 End Property ' SFDialogs.SF_DialogControl.Locked (let)
262 REM -----------------------------------------------------------------------------
263 Property Get MultiSelect() As Variant
264 ''' The MultiSelect property specifies whether a user can make multiple selections in a listbox
266 End Property ' SFDialogs.SF_DialogControl.MultiSelect (get)
268 REM -----------------------------------------------------------------------------
269 Property Let MultiSelect(Optional ByVal pvMultiSelect As Variant)
270 ''' Set the updatable property MultiSelect
272 End Property ' SFDialogs.SF_DialogControl.MultiSelect (let)
274 REM -----------------------------------------------------------------------------
275 Property Get Name() As String
276 ''' Return the name of the actual control
278 End Property ' SFDialogs.SF_DialogControl.Name
280 REM -----------------------------------------------------------------------------
281 Property Get OnActionPerformed() As Variant
282 ''' Get the script associated with the OnActionPerformed event
284 End Property ' SFDialogs.SF_DialogControl.OnActionPerformed (get)
286 REM -----------------------------------------------------------------------------
287 Property Get OnAdjustmentValueChanged() As Variant
288 ''' Get the script associated with the OnAdjustmentValueChanged event
290 End Property ' SFDialogs.SF_DialogControl.OnAdjustmentValueChanged (get)
292 REM -----------------------------------------------------------------------------
293 Property Get OnFocusGained() As Variant
294 ''' Get the script associated with the OnFocusGained event
296 End Property ' SFDialogs.SF_DialogControl.OnFocusGained (get)
298 REM -----------------------------------------------------------------------------
299 Property Get OnFocusLost() As Variant
300 ''' Get the script associated with the OnFocusLost event
302 End Property ' SFDialogs.SF_DialogControl.OnFocusLost (get)
304 REM -----------------------------------------------------------------------------
305 Property Get OnItemStateChanged() As Variant
306 ''' Get the script associated with the OnItemStateChanged event
308 End Property ' SFDialogs.SF_DialogControl.OnItemStateChanged (get)
310 REM -----------------------------------------------------------------------------
311 Property Get OnKeyPressed() As Variant
312 ''' Get the script associated with the OnKeyPressed event
314 End Property ' SFDialogs.SF_DialogControl.OnKeyPressed (get)
316 REM -----------------------------------------------------------------------------
317 Property Get OnKeyReleased() As Variant
318 ''' Get the script associated with the OnKeyReleased event
320 End Property ' SFDialogs.SF_DialogControl.OnKeyReleased (get)
322 REM -----------------------------------------------------------------------------
323 Property Get OnMouseDragged() As Variant
324 ''' Get the script associated with the OnMouseDragged event
326 End Property ' SFDialogs.SF_DialogControl.OnMouseDragged (get)
328 REM -----------------------------------------------------------------------------
329 Property Get OnMouseEntered() As Variant
330 ''' Get the script associated with the OnMouseEntered event
332 End Property ' SFDialogs.SF_DialogControl.OnMouseEntered (get)
334 REM -----------------------------------------------------------------------------
335 Property Get OnMouseExited() As Variant
336 ''' Get the script associated with the OnMouseExited event
338 End Property ' SFDialogs.SF_DialogControl.OnMouseExited (get)
340 REM -----------------------------------------------------------------------------
341 Property Get OnMouseMoved() As Variant
342 ''' Get the script associated with the OnMouseMoved event
344 End Property ' SFDialogs.SF_DialogControl.OnMouseMoved (get)
346 REM -----------------------------------------------------------------------------
347 Property Get OnMousePressed() As Variant
348 ''' Get the script associated with the OnMousePressed event
350 End Property ' SFDialogs.SF_DialogControl.OnMousePressed (get)
352 REM -----------------------------------------------------------------------------
353 Property Get OnMouseReleased() As Variant
354 ''' Get the script associated with the OnMouseReleased event
356 End Property ' SFDialogs.SF_DialogControl.OnMouseReleased (get)
358 REM -----------------------------------------------------------------------------
359 Property Get OnNodeExpanded() As Variant
360 ''' Get the script associated with the OnNodeExpanded event
362 End Property ' SFDialogs.SF_DialogControl.OnNodeExpanded (get)
364 REM -----------------------------------------------------------------------------
365 Property Let OnNodeExpanded(Optional ByVal pvOnNodeExpanded As Variant)
366 ''' Set the updatable property OnNodeExpanded
368 End Property ' SFDialogs.SF_DialogControl.OnNodeExpanded (let)
370 REM -----------------------------------------------------------------------------
371 Property Get OnNodeSelected() As Variant
372 ''' Get the script associated with the OnNodeSelected event
374 End Property ' SFDialogs.SF_DialogControl.OnNodeSelected (get)
376 REM -----------------------------------------------------------------------------
377 Property Let OnNodeSelected(Optional ByVal pvOnNodeSelected As Variant)
378 ''' Set the updatable property OnNodeSelected
380 End Property ' SFDialogs.SF_DialogControl.OnNodeSelected (let)
382 REM -----------------------------------------------------------------------------
383 Property Get OnTextChanged() As Variant
384 ''' Get the script associated with the OnTextChanged event
386 End Property ' SFDialogs.SF_DialogControl.OnTextChanged (get)
388 REM -----------------------------------------------------------------------------
389 Property Get Page() As Variant
390 ''' 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.
391 ''' The Page property of a control defines the page of the dialog on which the control is visible.
392 ''' For example, if a control has a page value of 1, it is only visible on page 1 of the dialog.
393 ''' 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.
395 End Property ' SFDialogs.SF_DialogControl.Page (get)
397 REM -----------------------------------------------------------------------------
398 Property Let Page(Optional ByVal pvPage As Variant)
399 ''' Set the updatable property Page
401 End Property ' SFDialogs.SF_DialogControl.Page (let)
403 REM -----------------------------------------------------------------------------
404 Property Get Parent() As Object
405 ''' Return the Parent dialog object of the actual control
407 End Property ' SFDialogs.SF_DialogControl.Parent
409 REM -----------------------------------------------------------------------------
410 Property Get Picture() As Variant
411 ''' The Picture property specifies a bitmap or other type of graphic to be displayed on the specified control
413 End Property ' SFDialogs.SF_DialogControl.Picture (get)
415 REM -----------------------------------------------------------------------------
416 Property Let Picture(Optional ByVal pvPicture As Variant)
417 ''' Set the updatable property Picture
419 End Property ' SFDialogs.SF_DialogControl.Picture (let)
421 REM -----------------------------------------------------------------------------
422 Property Get RootNode() As Variant
423 ''' The RootNode property returns the last root node of a tree control
425 End Property ' SFDialogs.SF_DialogControl.RootNode (get)
427 REM -----------------------------------------------------------------------------
428 Property Get RowSource() As Variant
429 ''' The RowSource property specifies the data contained in a combobox or a listbox
430 ''' as a zero-based array of string values
432 End Property ' SFDialogs.SF_DialogControl.RowSource (get)
434 REM -----------------------------------------------------------------------------
435 Property Let RowSource(Optional ByVal pvRowSource As Variant)
436 ''' Set the updatable property RowSource
438 End Property ' SFDialogs.SF_DialogControl.RowSource (let)
440 REM -----------------------------------------------------------------------------
441 Property Get Text() As Variant
442 ''' The Text property specifies the actual content of the control like it is displayed on the screen
444 End Property ' SFDialogs.SF_DialogControl.Text (get)
446 REM -----------------------------------------------------------------------------
447 Property Get TipText() As Variant
448 ''' The TipText property specifies the text that appears in a screentip when you hold the mouse pointer over a control
450 End Property ' SFDialogs.SF_DialogControl.TipText (get)
452 REM -----------------------------------------------------------------------------
453 Property Let TipText(Optional ByVal pvTipText As Variant)
454 ''' Set the updatable property TipText
456 End Property ' SFDialogs.SF_DialogControl.TipText (let)
458 REM -----------------------------------------------------------------------------
459 Property Get TripleState() As Variant
460 ''' The TripleState property specifies how a check box will display Null values
461 ''' 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.
462 ''' When False, the control will cycle through states for Yes and No values. Null values display as if they were No values.
464 End Property ' SFDialogs.SF_DialogControl.TripleState (get)
466 REM -----------------------------------------------------------------------------
467 Property Let TripleState(Optional ByVal pvTripleState As Variant)
468 ''' Set the updatable property TripleState
470 End Property ' SFDialogs.SF_DialogControl.TripleState (let)
472 REM -----------------------------------------------------------------------------
473 Property Get Value() As Variant
474 ''' The Value property specifies the data contained in the control
476 End Property ' SFDialogs.SF_DialogControl.Value (get)
478 REM -----------------------------------------------------------------------------
479 Property Let Value(Optional ByVal pvValue As Variant)
480 ''' Set the updatable property Value
482 End Property ' SFDialogs.SF_DialogControl.Value (let)
484 REM -----------------------------------------------------------------------------
485 Property Get Visible() As Variant
486 ''' The Visible property specifies if the control is accessible with the cursor.
488 End Property ' SFDialogs.SF_DialogControl.Visible (get)
490 REM -----------------------------------------------------------------------------
491 Property Let Visible(Optional ByVal pvVisible As Variant)
492 ''' Set the updatable property Visible
494 End Property ' SFDialogs.SF_DialogControl.Visible (let)
496 REM -----------------------------------------------------------------------------
497 Property Get XControlModel() As Object
498 ''' The XControlModel property returns the model UNO object of the control
500 End Property ' SFDialogs.SF_DialogControl.XControlModel (get)
502 REM -----------------------------------------------------------------------------
503 Property Get XControlView() As Object
504 ''' The XControlView property returns the view UNO object of the control
506 End Property ' SFDialogs.SF_DialogControl.XControlView (get)
508 REM -----------------------------------------------------------------------------
509 Property Get XGridColumnModel() As Object
510 ''' The XGridColumnModel property returns the mutable data model UNO object of the tree control
512 End Property ' SFDialogs.SF_DialogControl.XGridColumnModel (get)
514 REM -----------------------------------------------------------------------------
515 Property Get XGridDataModel() As Object
516 ''' The XGridDataModel property returns the mutable data model UNO object of the tree control
518 End Property ' SFDialogs.SF_DialogControl.XGridDataModel (get)
520 REM -----------------------------------------------------------------------------
521 Property Get XTreeDataModel() As Object
522 ''' The XTreeDataModel property returns the mutable data model UNO object of the tree control
524 End Property ' SFDialogs.SF_DialogControl.XTreeDataModel (get)
526 REM ===================================================================== METHODS
528 REM -----------------------------------------------------------------------------
529 Public Function AddSubNode(Optional ByRef ParentNode As Variant _
530 , Optional ByVal DisplayValue As Variant _
531 , Optional ByRef DataValue As Variant _
532 ) As Variant
533 ''' Return a new node of the tree control subordinate to a parent node
534 ''' Args:
535 ''' ParentNode: A node UNO object, of type com.sun.star.awt.tree.XMutableTreeNode
536 ''' DisplayValue: the text appearing in the control box
537 ''' DataValue: any value associated with the new node. Default = Empty
538 ''' Returns:
539 ''' The new node UNO object: com.sun.star.awt.tree.XMutableTreeNode
540 ''' Examples:
541 ''' Dim myTree As Object, myNode As Object, theRoot As Object
546 Dim oNode As Object ' Return value
550 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
551 Set oNode = Nothing
553 Check:
554 If IsMissing(DataValue) Then DataValue = Empty
555 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
556 If _ControlType <> CTLTREECONTROL Then GoTo CatchType
557 If Not ScriptForge.SF_Utils._Validate(ParentNode, "ParentNode", V_OBJECT) Then GoTo Catch
558 If ScriptForge.SF_Session.UnoObjectType(ParentNode) <> "toolkit.MutableTreeNode" Then GoTo Catch
559 If Not ScriptForge.SF_Utils._Validate(DisplayValue, "DisplayValue", V_STRING) Then GoTo Catch
560 End If
562 Try:
563 With _TreeDataModel
564 Set oNode = .createNode(DisplayValue, True)
565 oNode.DataValue = DataValue
566 ParentNode.appendChild(oNode)
567 End With
569 Finally:
570 Set AddSubNode = oNode
571 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
572 Exit Function
573 Catch:
574 GoTo Finally
575 CatchType:
576 ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "AddSubNode")
577 GoTo Finally
578 End Function ' SFDialogs.SF_DialogControl.AddSubNode
580 REM -----------------------------------------------------------------------------
581 Public Function AddSubTree(Optional ByRef ParentNode As Variant _
582 , Optional ByRef FlatTree As Variant _
583 , Optional ByVal WithDataValue As Variant _
584 ) As Boolean
585 ''' Return True when a subtree, subordinate to a parent node, could be inserted successfully in a tree control
586 ''' If the parent node had already child nodes before calling this method, the child nodes are erased
587 ''' Args:
588 ''' ParentNode: A node UNO object, of type com.sun.star.awt.tree.XMutableTreeNode
591 ''' A1 B1 C1 |__ A1
592 ''' A1 B1 C2 |__ B1
593 ''' A1 B2 C3 |__ C1
594 ''' A2 B3 C4 |__ C2
595 ''' A2 B3 C5 |__ B2
596 ''' A3 B4 C6 |__ C3
597 ''' |__ A2
598 ''' |__ B3
599 ''' |__ C4
600 ''' |__ C5
601 ''' |__ A3
602 ''' |__ B4
603 ''' |__ C6
604 ''' Typically, such an array can be issued by the GetRows method applied on the SFDatabases.Database service
605 ''' when an array item containing the text to be displayed is = "" or is empty/null,
606 ''' no new subnode is created and the remainder of the row is skipped
607 ''' When AddSubTree() is called from a Python script, FlatTree may be an array of arrays
608 ''' WithDataValue:
609 ''' When False (default), every column of FlatTree contains the text to be displayed in the tree control
610 ''' When True, the texts to be displayed (DisplayValue) are in columns 0, 2, 4, ...
612 ''' Returns:
613 ''' True when successful
614 ''' Examples:
615 ''' Dim myTree As Object, theRoot As Object, oDb As Object, vData As Variant
618 ''' Set oDb = CreateScriptService("SFDatabases.Database", "/home/.../mydatabase.odb")
619 ''' vData = oDb.GetRows("SELECT [Category].[Name], [Category].[ID], [Product].[Name], [Product].[ID] " _
620 ''' & "FROM [Category], [Product] WHERE [Product].[CategoryID] = [Category].[ID] " _
622 ''' myTree.AddSubTree(theRoot, vData, WithDataValue := True)
624 Dim bSubTree As Boolean ' Return value
625 Dim oNode As Object ' com.sun.star.awt.tree.XMutableTreeNode
626 Dim oNewNode As Object ' com.sun.star.awt.tree.XMutableTreeNode
627 Dim lChildCount As Long ' Number of children nodes of a parent node
629 Dim iDims As Integer ' Number of dimensions of FlatTree
630 Dim lMin1 As Long ' Lower bound (rows)
631 Dim lMin2 As Long ' Lower bounds (cols)
632 Dim lMax1 As Long ' Upper bound (rows)
633 Dim lMax2 As Long ' Upper bounds (cols)
634 Dim vFlatItem As Variant ' A single FlatTree item: FlatTree(i, j)
635 Dim vFlatItem2 As Variant ' A single FlatTree item
636 Dim bChange As Boolean ' When True, the item in FlatTree is different from the item above
637 Dim sValue As String ' Alias for display values
638 Dim i As Long, j As Long
642 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
643 bSubTree = False
645 Check:
646 If IsMissing(WithDataValue) Or IsEmpty(WithDataValue) Then WithDataValue = False
647 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
648 If _ControlType <> CTLTREECONTROL Then GoTo CatchType
649 If Not ScriptForge.SF_Utils._Validate(ParentNode, "ParentNode", V_OBJECT) Then GoTo Catch
650 If ScriptForge.SF_Session.UnoObjectType(ParentNode) <> "toolkit.MutableTreeNode" Then GoTo Catch
651 If Not ScriptForge.SF_Utils._ValidateArray(FlatTree, "FlatTree") Then GoTo Catch ' Dimensions checked below
652 If Not ScriptForge.SF_Utils._Validate(WithDataValue, "WithDataValue", V_BOOLEAN) Then GoTo Catch
653 End If
655 Try:
656 With _TreeDataModel
657 ' Clean subtree
658 lChildCount = ParentNode.getChildCount()
659 For i = 1 To lChildCount
661 Next i
663 ' Determine bounds
664 iDims = ScriptForge.SF_Array.CountDims(FlatTree)
665 Select Case iDims
669 If Not IsArray(FlatTree(0)) Then GoTo Catch
672 Case 2
675 Case Else : GoTo Catch
676 End Select
678 ' Build a new subtree
680 For i = lMin1 To lMax1
681 bChange = ( i = 0 )
682 ' Restart from the parent node at each i-iteration
683 Set oNode = ParentNode
684 For j = lMin2 To lMax2 Step iStep ' Array columns
685 If iDims = 1 Then vFlatItem = FlatTree(i)(j) Else vFlatItem = FlatTree(i, j)
686 If vFlatItem = "" Or IsNull(vFlatItem) Or IsEmpty(vFlatItem) Then
687 Set oNode = Nothing
688 Exit For ' Exit j-loop
689 End If
690 If Not bChange Then
692 bChange = ( vFlatItem <> vFlatItem2 )
693 End If
694 If bChange Then ' Create new subnode at tree depth = j
695 If VarType(vFlatItem) = V_STRING Then sValue = vFlatItem Else sValue = ScriptForge.SF_String.Represent(vFlatItem)
696 Set oNewNode = .createNode(sValue, True)
697 If WithDataValue Then
699 oNewNode.DataValue = vFlatItem2
700 End If
701 oNode.appendChild(oNewNode)
702 Set oNode = oNewNode
703 Else
704 ' Position next current node on last child of actual current node
705 lChildCount = oNode.getChildCount()
706 If lChildCount > 0 Then Set oNode = oNode.getChildAt(lChildCount - 1) Else Set oNode = Nothing
707 End If
708 Next j
709 Next i
710 bSubTree = True
711 End With
713 Finally:
714 AddSubTree = bSubTree
715 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
716 Exit Function
717 Catch:
718 GoTo Finally
719 CatchType:
720 ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "AddSubTree")
721 GoTo Finally
722 End Function ' SFDialogs.SF_DialogControl.AddSubTree
724 REM -----------------------------------------------------------------------------
725 Public Function CreateRoot(Optional ByVal DisplayValue As Variant _
726 , Optional ByRef DataValue As Variant _
727 ) As Variant
728 ''' Return a new root node of the tree control. The new tree root is inserted below pre-existing root nodes
729 ''' Args:
730 ''' DisplayValue: the text appearing in the control box
731 ''' DataValue: any value associated with the root node. Default = Empty
732 ''' Returns:
733 ''' The new root node as a UNO object of type com.sun.star.awt.tree.XMutableTreeNode
734 ''' Examples:
735 ''' Dim myTree As Object, myNode As Object
739 Dim oRoot As Object ' Return value
743 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
744 Set oRoot = Nothing
746 Check:
747 If IsMissing(DataValue) Then DataValue = Empty
748 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
749 If _ControlType <> CTLTREECONTROL Then GoTo CatchType
750 If Not ScriptForge.SF_Utils._Validate(DisplayValue, "DisplayValue", V_STRING) Then GoTo Catch
751 End If
753 Try:
754 With _TreeDataModel
755 Set oRoot = .createNode(DisplayValue, True)
756 oRoot.DataValue = DataValue
757 .setRoot(oRoot)
758 ' To be visible, a root must have contained at least 1 child. Create a fictive one and erase it.
759 ' This behaviour does not seem related to the RootDisplayed property ??
761 oRoot.removeChildByIndex(0)
762 End With
764 Finally:
765 Set CreateRoot = oRoot
766 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
767 Exit Function
768 Catch:
769 GoTo Finally
770 CatchType:
771 ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "CreateRoot")
772 GoTo Finally
773 End Function ' SFDialogs.SF_DialogControl.CreateRoot
775 REM -----------------------------------------------------------------------------
776 Public Function FindNode(Optional ByVal DisplayValue As String _
777 , Optional ByRef DataValue As Variant _
778 , Optional ByVal CaseSensitive As Boolean _
779 ) As Object
780 ''' Traverses the tree and find recursively, starting from the root, a node meeting some criteria
782 ''' having its DisplayValue like DisplayValue
783 ''' having its DataValue = DataValue
784 ''' Comparisons may be or not case-sensitive
785 ''' The first matching occurrence is returned
786 ''' Args:
787 ''' DisplayValue: the pattern to be matched
788 ''' DataValue: a string, a numeric value or a date or Empty (if not applicable)
789 ''' CaseSensitive: applicable on both criteria. Default = False
790 ''' Returns:
791 ''' The found node of type com.sun.star.awt.tree.XMutableTreeNode or Nothing if not found
792 ''' Examples:
793 ''' Dim myTree As Object, myNode As Object
798 Dim oNode As Object ' Return value
800 Const cstSubArgs = "[DisplayValue=""""], [DataValue=Empty], [CaseSensitive=False]"
802 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
803 Set oNode = Nothing
805 Check:
806 If IsMissing(DisplayValue) Or IsEmpty(DisplayValue) Then DisplayValue = ""
807 If IsMissing(DataValue) Then DataValue = Empty
808 If IsMissing(CaseSensitive) Or IsEmpty(CaseSensitive) Then CaseSensitive = False
809 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
810 If _ControlType <> CTLTREECONTROL Then GoTo CatchType
811 If Not ScriptForge.SF_Utils._Validate(DisplayValue, "DisplayValue", V_STRING) Then GoTo Catch
812 If Not ScriptForge.SF_Utils._Validate(CaseSensitive, "CaseSensitive", ScriptForge.V_BOOLEAN) Then GoTo Catch
813 End If
815 Try:
816 Set oNode = _FindNode(_TreeDataModel.getRoot(), DisplayValue, DataValue, CaseSensitive)
818 Finally:
819 Set FindNode = oNode
820 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
821 Exit Function
822 Catch:
823 GoTo Finally
824 CatchType:
825 ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "FindNode")
826 GoTo Finally
827 End Function ' SFDialogs.SF_DialogControl.FindNode
829 REM -----------------------------------------------------------------------------
830 Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
831 ''' Return the actual value of the given property
832 ''' Args:
833 ''' PropertyName: the name of the property as a string
834 ''' Returns:
835 ''' The actual value of the property
836 ''' If the property does not exist, returns Null
837 ''' Exceptions:
838 ''' see the exceptions of the individual properties
839 ''' Examples:
843 Const cstSubArgs = ""
845 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
846 GetProperty = Null
848 Check:
849 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
850 If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
851 End If
853 Try:
854 GetProperty = _PropertyGet(PropertyName)
856 Finally:
857 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
858 Exit Function
859 Catch:
860 GoTo Finally
861 End Function ' SFDialogs.SF_DialogControl.GetProperty
863 REM -----------------------------------------------------------------------------
864 Public Function Methods() As Variant
865 ''' Return the list of public methods of the Model service as an array
867 Methods = Array( _
874 )
876 End Function ' SFDialogs.SF_DialogControl.Methods
878 REM -----------------------------------------------------------------------------
879 Public Function Properties() As Variant
880 ''' Return the list or properties of the Timer class as an array
882 Properties = Array( _
926 )
928 End Function ' SFDialogs.SF_DialogControl.Properties
930 REM -----------------------------------------------------------------------------
931 Public Function SetFocus() As Boolean
932 ''' Set the focus on the current Control instance
933 ''' Probably called from after an event occurrence
934 ''' Args:
935 ''' Returns:
936 ''' True if focusing is successful
937 ''' Example:
938 ''' Dim oDlg As Object, oControl As Object
939 ''' Set oDlg = CreateScriptService(,, "myControl") ' Control stored in current document's standard library
941 ''' oControl.SetFocus()
943 Dim bSetFocus As Boolean ' Return value
945 Const cstSubArgs = ""
947 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
948 bSetFocus = False
950 Check:
951 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
952 If Not [_Parent]._IsStillAlive() Then GoTo Finally
953 End If
955 Try:
956 If Not IsNull(_ControlView) Then
957 _ControlView.setFocus()
958 bSetFocus = True
959 End If
961 Finally:
962 SetFocus = bSetFocus
963 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
964 Exit Function
965 Catch:
966 GoTo Finally
967 End Function ' SFControls.SF_DialogControl.SetFocus
969 REM -----------------------------------------------------------------------------
970 Public Function SetProperty(Optional ByVal PropertyName As Variant _
971 , Optional ByRef Value As Variant _
972 ) As Boolean
973 ''' Set a new value to the given property
974 ''' Args:
975 ''' PropertyName: the name of the property as a string
976 ''' Value: its new value
977 ''' Exceptions
978 ''' ARGUMENTERROR The property does not exist
983 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
984 SetProperty = False
986 Check:
987 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
988 If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
989 End If
991 Try:
992 SetProperty = _PropertySet(PropertyName, Value)
994 Finally:
995 SF_Utils._ExitFunction(cstThisSub)
996 Exit Function
997 Catch:
998 GoTo Finally
999 End Function ' SFDialogs.SF_DialogControl.SetProperty
1001 REM -----------------------------------------------------------------------------
1002 Public Function SetTableData(Optional ByRef DataArray As Variant _
1003 , Optional ByRef Widths As Variant _
1004 , Optional ByRef Alignments As Variant _
1005 ) As Boolean
1006 ''' Fill a table control with the given data. Preexisting data is erased
1007 ''' The Basic IDE allows to define if the control has a row and/or a column header
1008 ''' When it is the case, the array in argument should contain those headers resp. in the first
1009 ''' column and/or in the first row
1010 ''' A column in the control shall be sortable when the data (headers excluded) in that column
1011 ''' is homogeneously filled either with numbers or with strings
1012 ''' Columns containing strings will be left-aligned, those with numbers will be right-aligned
1013 ''' Args:
1014 ''' DataArray: the set of data to display in the table control, including optional column/row headers
1016 ''' Widths: the column's relative widths as a 1D array, each element corresponding with a column
1017 ''' If the array is shorter than the number of columns, the last value is kept for the next columns.
1018 ''' Example:
1020 ''' means that the first column is half as wide as all the other columns
1021 ''' When the argument is absent, the columns are evenly spread over the control
1022 ''' Alignments: the column's horizontal alignment as a string with length = number of columns.
1023 ''' Possible characters are:
1024 ''' L(EFT), C(ENTER), R(IGHT) or space (default behaviour)
1025 ''' Returns:
1026 ''' True when successful
1027 ''' Examples:
1028 ''' Dim myTable As Object, bSet As Boolean, vData As Variant
1029 ''' Set myTable = myDialog.Controls("myTableControl") ' This control has only column headers
1036 Dim bData As Boolean ' Return value
1037 Dim iDims As Integer ' Number of dimensions of DataArray
1038 Dim lMin1 As Long ' LBound1 of input array
1039 Dim lMax1 As Long ' UBound1 of input array
1040 Dim lMin2 As Long ' LBound2 of input array
1041 Dim lMax2 As Long ' UBound2 of input array
1042 Dim lControlWidth As Long ' Width of the table control
1043 Dim lMinW As Long ' lBound of Widths
1044 Dim lMaxW As Long ' UBound of vWidths
1045 Dim lMinRow As Long ' Row index of effective data subarray
1046 Dim lMinCol As Long ' Column index of effective data subarray
1047 Dim vRowHeaders As Variant ' Array of row headers
1048 Dim sRowHeader As String ' A single row header
1049 Dim vColHeaders As Variant ' Array of column headers
1050 Dim oColumn As Object ' com.sun.star.awt.grid.XGridColumn
1051 Dim dWidth As Double ' A single item of Widths
1052 Dim dRelativeWidth As Double ' Sum of Widths up to the number of columns
1053 Dim dWidthFactor As Double ' Factor to apply to relative widths to get absolute column widths
1054 Dim vDataRow As Variant ' A single row content in the tablecontrol
1055 Dim vDataItem As Variant ' A single DataArray item
1057 Dim lAlign As Long ' com.sun.star.style.HorizontalAlignment.XXX
1058 Dim i As Long, j As Long, k As Long
1063 Const cstSubArgs = "DataArray, [Widths=Array(1)], [Alignments=""""]"
1065 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1066 bData = False
1068 Check:
1069 If IsMissing(Widths) Or IsEmpty(Widths) Then Widths = Array(1)
1070 If IsMissing(Alignments) Or IsEmpty(Alignments) Then Alignments = ""
1071 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1072 If _ControlType <> CTLTABLECONTROL Then GoTo CatchType
1073 If Not ScriptForge.SF_Utils._ValidateArray(DataArray, "DataArray") Then GoTo Catch ' Dimensions are checked below
1074 If Not ScriptForge.SF_Utils._ValidateArray(Widths, "Widths", 1, ScriptForge.V_NUMERIC, True) Then GoTo Catch
1075 If Not ScriptForge.SF_Utils._Validate(Alignments, "Alignments", V_STRING) Then GoTo Catch
1076 End If
1078 Try:
1079 ' Erase any pre-existing data and columns
1080 _GridDataModel.removeAllRows()
1082 _GridColumnModel.removeColumn(i)
1083 Next i
1085 ' LBounds, UBounds - Basic or Pytho
1086 iDims = ScriptForge.SF_Array.CountDims(DataArray)
1087 Select Case iDims
1091 If Not IsArray(DataArray(0)) Then GoTo Catch
1094 Case 2
1097 Case Else : GoTo Catch
1098 End Select
1100 ' Extract headers from data array
1101 lMinW = LBound(Widths) : lMaxW = UBound(Widths)
1102 With _ControlModel
1103 If .ShowColumnHeader Then
1104 lMinRow = lMin1 + 1
1105 If iDims = 1 Then
1106 vColHeaders = DataArray(lMin1)
1107 Else
1108 vColHeaders = ScriptForge.SF_Array.ExtractRow(DataArray, lMin1)
1109 End If
1110 Else
1111 lMinRow = lMin1
1112 vColHeaders = Array()
1113 End If
1114 If .ShowRowHeader Then
1115 lMinCol = lMin2 + 1
1116 If iDims = 1 Then
1117 vRowHeaders = Array()
1118 ReDim vRowHeaders(lMin1 To lMax1)
1119 For i = lMin1 To lMax1
1120 vRowHeaders(i) = DataArray(i)(lMin2)
1121 Next i
1122 Else
1123 vRowHeaders = ScriptForge.SF_Array.ExtractColumn(DataArray, lMin2)
1124 End If
1125 Else
1126 lMinCol = lMin2
1127 vRowHeaders = Array()
1128 End If
1129 End With
1131 ' Create the columns
1132 For j = lMinCol To lMax2
1133 Set oColumn = _GridColumnModel.createColumn()
1134 If _ControlModel.ShowColumnHeader Then oColumn.Title = vColHeaders(j)
1135 _GridColumnModel.addColumn(oColumn)
1136 Next j
1137 ' Size the columns. Column sizing cannot be done before all the columns are added
1139 ' Size the columns proportionally with their relative widths
1140 dRelativeWidth = 0.0
1141 i = lMinW - 1
1142 ' Compute the sum of the relative widths
1143 For j = 0 To lMax2 - lMinCol
1144 i = i + 1
1145 If i >= lMinW And i <= lMaxW Then dRelativeWidth = dRelativeWidth + Widths(i) Else dRelativeWidth = dRelativeWidth + Widths(lMaxW)
1146 Next j
1147 ' Set absolute widths
1148 If dRelativeWidth > 0.0 Then dWidthFactor = CDbl((_ControlModel.Width - cstRowHdrWidth) / dRelativeWidth) Else dWidthFactor = 1.0
1149 i = lMinW - 1
1150 For j = 0 To lMax2 - lMinCol
1151 i = i + 1
1152 If i >= lMinW And i <= lMaxW Then dWidth = CDbl(Widths(i)) Else dWidth = CDbl(Widths(lMaxW))
1153 _GridColumnModel.Columns(j).ColumnWidth = CLng(dWidthFactor * dWidth)
1154 Next j
1155 Else
1156 ' Size all columns evenly
1157 For j = 0 To lMax2 - lMinCol
1158 _GridColumnModel.Columns(j).ColumnWidth = (_ControlModel.Width - cstRowHdrWidth) / (lMax2 - lMonCol + 1)
1159 Next j
1160 End If
1162 ' Initialize the column alignment
1163 If Len(Alignments) >= lMax2 - lMinCol + 1 Then sAlign = Alignments Else sAlign = Alignments & Space(lMax2 - lMinCol + 1 - Len(Alignments))
1165 ' Feed the table with data and define/confirm the column alignment
1166 vDataRow = Array()
1167 For i = lMinRow To lMax1
1168 ReDim vDataRow(0 To lMax2 - lMinCol)
1169 For j = lMinCol To lMax2
1170 If iDims = 1 Then vDataItem = DataArray(i)(j) Else vDataItem = DataArray(i, j)
1171 If VarType(vDataItem) = V_STRING Then
1172 ElseIf ScriptForge.SF_Utils._VarTypeExt(vDataItem) = ScriptForge.V_NUMERIC Then
1173 Else
1174 vDataItem = ScriptForge.SF_String.Represent(vDataItem)
1175 End If
1176 vDataRow(j - lMinCol) = vDataItem
1177 ' Store alignment while processing the first row of the array
1178 If i = lMinRow Then
1179 k = j - lMinCol + 1
1180 If Mid(sAlign, k, 1) = " " Then Mid(sAlign, k, 1) = Iif(VarType(vDataItem) = V_STRING, "L", "R")
1181 End If
1182 Next j
1183 If _ControlModel.ShowRowHeader Then sRowHeader = vRowHeaders(i) Else sRowHeader = ""
1184 _GridDataModel.addRow(sRowHeader, vDataRow)
1185 Next i
1187 ' Determine alignments of each column
1188 For j = 0 To lMax2 - lMinCol
1193 Case Else
1194 End Select
1195 _GridColumnModel.Columns(j).HorizontalAlign = lAlign
1196 Next j
1198 bData = True
1200 Finally:
1201 SetTableData = bData
1202 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1203 Exit Function
1204 Catch:
1205 GoTo Finally
1206 CatchType:
1207 ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, "SetTableData")
1208 GoTo Finally
1209 End Function ' SFDialogs.SF_DialogControl.SetTableData
1211 REM -----------------------------------------------------------------------------
1212 Public Function WriteLine(Optional ByVal Line As Variant) As Boolean
1213 ''' Add a new line to a multiline TextField control
1214 ''' Args:
1215 ''' Line: (default = "") the line to insert at the end of the text box
1216 ''' a newline character will be inserted before the line, if relevant
1217 ''' Returns:
1218 ''' True if insertion is successful
1219 ''' Exceptions
1220 ''' TEXTFIELDERROR Method applicable on multiline text fields only
1221 ''' Example:
1222 ''' Dim oDlg As Object, oControl As Object
1223 ''' Set oDlg = CreateScriptService(,, "myControl") ' Control stored in current document's standard library
1227 Dim bWriteLine As Boolean ' Return value
1228 Dim lTextLength As Long ' Actual length of text in box
1229 Dim oSelection As New com.sun.star.awt.Selection
1230 Dim sNewLine As String ' Newline character(s)
1234 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1235 bWriteLine = False
1237 Check:
1238 If IsMissing(Line) Or IsEmpty(Line) Then Line = ""
1239 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1240 If Not [_Parent]._IsStillAlive() Then GoTo Finally
1242 End If
1243 If ControlType <> CTLTEXTFIELD Then GoTo CatchField
1244 If _ControlModel.MultiLine = False Then GoTo CatchField
1246 Try:
1247 _ControlModel.HardLineBreaks = True
1248 sNewLine = ScriptForge.SF_String.sfNEWLINE
1249 With _ControlView
1250 lTextLength = Len(.getText())
1253 .setText(Line)
1254 Else ' Put cursor at the end of the actual text
1255 oSelection.Min = lTextLength : oSelection.Max = lTextLength
1256 .insertText(oSelection, sNewLine & Line)
1257 End If
1258 ' Put the cursor at the end of the inserted text
1259 oSelection.Max = oSelection.Max + Len(sNewLine) + Len(Line)
1260 oSelection.Min = oSelection.Max
1261 .setSelection(oSelection)
1262 End With
1263 bWriteLine = True
1265 Finally:
1266 WriteLine = bWriteLine
1267 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1268 Exit Function
1269 Catch:
1270 GoTo Finally
1271 CatchField:
1272 ScriptForge.SF_Exception.RaiseFatal(TEXTFIELDERROR, _Name, _DialogName)
1273 GoTo Finally
1274 End Function ' SFControls.SF_DialogControl.WriteLine
1276 REM =========================================================== PRIVATE FUNCTIONS
1278 REM -----------------------------------------------------------------------------
1279 Private Function _FindNode(ByRef poNode As Object _
1280 , ByVal psDisplayValue As String _
1281 , ByRef pvDataValue As Variant _
1282 , ByVal pbCaseSensitive As Boolean _
1283 ) As Object
1284 ''' Traverses the tree and find recursively, starting from the root, a node meeting some criteria
1286 ''' having its DisplayValue like psDisplayValue
1287 ''' having its DataValue = pvDataValue
1288 ''' Comparisons may be or not case-sensitive
1289 ''' The first matching occurrence is returned
1290 ''' Args:
1292 ''' psDisplayValue: the pattern to be matched
1293 ''' pvDataValue: a string, a numeric value or a date or Empty (if not applicable)
1294 ''' pbCaseSensitive: applicable on both criteria
1295 ''' Returns:
1296 ''' The found node of type com.sun.star.awt.tree.XMutableTreeNode
1298 Dim oChild As Object ' Child node com.sun.star.awt.tree.XMutableTreeNode
1299 Dim oFind As Object ' Found node com.sun.star.awt.tree.XMutableTreeNode
1300 Dim lChildCount As Long ' Number of children of a node
1301 Dim bFound As Boolean ' True when node found
1302 Dim i As Long
1304 Set _FindNode = Nothing
1305 On Local Error GoTo Finally ' Better not found than raise an error
1307 Check:
1308 ' Does the actual node match the criteria ?
1309 bFound = False
1311 bFound = ScriptForge.SF_String.IsLike(poNode.DisplayValue, psDisplayValue, pbCaseSensitive)
1312 End If
1313 If Not bFound And Not IsEmpty(poNode.DataValue) Then
1314 If Not IsEmpty(pvdataValue) Then bFound = ( ScriptForge.SF_Array._ValCompare(poNode.DataValue, pvDataB-Value, pbCaseSensitive) = 0 )
1315 End If
1316 If bFound Then
1317 Set _FindNode = poNode
1318 Exit Function
1319 End If
1321 Try:
1322 ' Explore sub-branches
1323 lChildCount = poNode.getChildCount
1326 Set oChild = poNode.getChildAt(i)
1327 Set oFind = _FindNode(oChild, psDisplayValue, pvDataValue, pbCaseSensitive) ' Recursive call
1328 If Not IsNull(oFind) Then
1329 Set _FindNode = oFind
1330 Exit For
1331 End If
1332 Next i
1333 End If
1335 Finally:
1336 Exit Function
1337 End Function ' SFDialogs.SF_DialogControl._FindNode
1339 REM -----------------------------------------------------------------------------
1340 Private Function _FormatsList() As Variant
1341 ''' Return the allowed format entries as a zero-based array for Date and Time control types
1343 Dim vFormats() As Variant ' Return value
1345 Select Case _ControlType
1346 Case CTLDATEFIELD
1347 vFormats = Array( _
1360 )
1361 Case CTLTIMEFIELD
1362 vFormats = Array( _
1367 )
1368 Case Else
1369 vFormats = Array()
1370 End Select
1372 _FormatsList = vFormats
1374 End Function ' SFDialogs.SF_DialogControl._FormatsList
1376 REM -----------------------------------------------------------------------------
1377 Public Function _GetEventName(ByVal psProperty As String) As String
1378 ''' Return the LO internal event name derived from the SF property name
1379 ''' The SF property name is not case sensitive, while the LO name is case-sensitive
1380 ' Corrects the typo on ErrorOccur(r?)ed, if necessary
1382 Dim vProperties As Variant ' Array of class properties
1383 Dim sProperty As String ' Correctly cased property name
1385 vProperties = Properties()
1386 sProperty = vProperties(ScriptForge.SF_Array.IndexOf(vProperties, psProperty, SortOrder := "ASC"))
1390 End Function ' SFDialogs.SF_DialogControl._GetEventName
1392 REM -----------------------------------------------------------------------------
1393 Private Function _GetListener(ByVal psEventName As String) As String
1394 ''' Getting/Setting macros triggered by events requires a Listener-EventName pair
1395 ''' Return the X...Listener corresponding with the event name in argument
1397 Select Case UCase(psEventName)
1410 Case UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMousePressed"), UCase("OnMouseReleased")
1414 Case Else
1415 _GetListener = ""
1416 End Select
1418 End Function ' SFDialogs.SF_DialogControl._GetListener
1420 REM -----------------------------------------------------------------------------
1421 Public Sub _Initialize()
1422 ''' Complete the object creation process:
1423 ''' - Initialization of private members
1424 ''' - Collection of specific attributes
1425 ''' - synchronization with parent dialog instance
1427 Dim vServiceName As Variant ' Split service name
1428 Dim sType As String ' Last component of service name
1430 Try:
1431 _ImplementationName = _ControlModel.getImplementationName()
1433 ' Identify the control type
1435 sType = vServiceName(UBound(vServiceName))
1436 Select Case sType
1438 _ControlType = "" ' Not supported
1441 ' Initialize the data model
1442 _ControlType = CTLTREECONTROL
1443 Set _ControlModel.DataModel = CreateUnoService("com.sun.star.awt.tree.MutableTreeDataModel")
1444 Set _TreeDataModel = _ControlModel.DataModel
1446 _ControlType = CTLTABLECONTROL
1447 Set _GridColumnModel = _ControlModel.ColumnModel
1448 Set _GridDataModel = _ControlModel.GridDataModel
1449 Case Else : _ControlType = sType
1450 End Select
1452 ' Store the SF_DialogControl object in the parent cache
1453 Set _Parent._ControlCache(_IndexOfNames) = [Me]
1455 Finally:
1456 Exit Sub
1457 End Sub ' SFDialogs.SF_DialogControl._Initialize
1459 REM -----------------------------------------------------------------------------
1460 Private Function _PropertyGet(Optional ByVal psProperty As String _
1461 , Optional ByVal pvDefault As Variant _
1462 ) As Variant
1463 ''' Return the value of the named property
1464 ''' Args:
1465 ''' psProperty: the name of the property
1466 ''' pvDefault: the value returned when the property is not applicable on the control's type
1467 ''' Getting a non-existing property for a specific control type should
1468 ''' not generate an error to not disrupt the Basic IDE debugger
1470 Dim vGet As Variant ' Return value
1471 Static oSession As Object ' Alias of SF_Session
1472 Dim vSelection As Variant ' Alias of Model.SelectedItems or Model.Selection
1473 Dim vList As Variant ' Alias of Model.StringItemList
1474 Dim lIndex As Long ' Index in StringItemList
1475 Dim sItem As String ' A single item
1476 Dim vDate As Variant ' com.sun.star.util.Date or com.sun.star.util.Time
1477 Dim vValues As Variant ' Array of listbox values
1478 Dim oControlEvents As Object ' com.sun.star.container.XNameContainer
1479 Dim sEventName As String ' Internal event name
1480 Dim i As Long
1481 Dim cstThisSub As String
1482 Const cstSubArgs = ""
1485 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1487 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
1488 If Not [_Parent]._IsStillAlive() Then GoTo Finally
1490 If IsMissing(pvDefault) Then pvDefault = Null
1491 _PropertyGet = pvDefault
1493 If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session")
1494 Select Case UCase(psProperty)
1496 Select Case _ControlType
1497 Case CTLBUTTON
1498 If oSession.HasUNOProperty(_ControlModel, "PushButtonType") Then _PropertyGet = ( _ControlModel.PushButtonType = com.sun.star.awt.PushButtonType.CANCEL )
1499 Case Else : GoTo CatchType
1500 End Select
1502 Select Case _ControlType
1503 Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDLINE, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON
1504 If oSession.HasUNOProperty(_ControlModel, "Label") Then _PropertyGet = _ControlModel.Label
1505 Case Else : GoTo CatchType
1506 End Select
1508 _PropertyGet = _ControlType
1510 Select Case _ControlType
1511 Case CTLTREECONTROL
1513 _PropertyGet = Empty
1514 If _ControlModel.SelectionType <> com.sun.star.view.SelectionType.NONE Then
1515 vSelection = _ControlView.getSelection()
1516 If IsArray(vSelection) Then
1518 Else
1519 Set _PropertyGet = vSelection
1520 End If
1521 End If
1522 End If
1523 Case Else : GoTo CatchType
1524 End Select
1526 Select Case _ControlType
1527 Case CTLBUTTON
1528 If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _PropertyGet = _ControlModel.DefaultButton
1529 Case Else : GoTo CatchType
1530 End Select
1532 If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _PropertyGet = _ControlModel.Enabled
1534 Select Case _ControlType
1535 Case CTLDATEFIELD
1536 If oSession.HasUNOProperty(_ControlModel, "DateFormat") Then _PropertyGet = _FormatsList()(_ControlModel.DateFormat)
1537 Case CTLTIMEFIELD
1538 If oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then _PropertyGet = _FormatsList()(_ControlModel.TimeFormat)
1539 Case CTLFORMATTEDFIELD
1540 If oSession.HasUNOProperty(_ControlModel, "FormatsSupplier") And oSession.HasUNOProperty(_ControlModel, "FormatKey") Then
1541 _PropertyGet = _ControlModel.FormatsSupplier.getNumberFormats.getByKey(_ControlModel.FormatKey).FormatString
1542 End If
1543 Case Else : GoTo CatchType
1544 End Select
1546 Select Case _ControlType
1547 Case CTLCOMBOBOX, CTLLISTBOX
1548 If oSession.HasUNOProperty(_ControlModel, "StringItemList") Then _PropertyGet = UBound(_ControlModel.StringItemList) + 1
1549 Case CTLTABLECONTROL ' Returns zero when no table data yet
1550 If oSession.HasUNOProperty(_GridDataModel, "RowCount") Then _PropertyGet = _GridDataModel.RowCount
1551 Case Else : GoTo CatchType
1552 End Select
1554 Select Case _ControlType
1555 Case CTLCOMBOBOX
1557 If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then
1558 _PropertyGet = ScriptForge.SF_Array.IndexOf(_ControlModel.StringItemList, _ControlModel.Text, CaseSensitive := True)
1559 End If
1560 Case CTLLISTBOX
1562 If oSession.HasUNOProperty(_ControlModel, "SelectedItems") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then
1563 vSelection = _ControlModel.SelectedItems
1565 End If
1566 Case CTLTABLECONTROL
1570 ' Other selection types (multi, range) not supported
1571 If _ControlModel.SelectionModel = com.sun.star.view.SelectionType.SINGLE Then
1572 lIndex = _ControlView.CurrentRow
1575 End If
1576 _PropertyGet = lIndex
1577 End If
1578 End If
1579 Case Else : GoTo CatchType
1580 End Select
1582 Select Case _ControlType
1583 Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLLISTBOX _
1584 , CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD
1585 If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _PropertyGet = _ControlModel.ReadOnly
1586 Case Else : GoTo CatchType
1587 End Select
1589 Select Case _ControlType
1590 Case CTLLISTBOX
1592 _PropertyGet = _ControlModel.MultiSelection
1593 ElseIf oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then ' Not documented: gridcontrols only TBC ??
1594 _PropertyGet = _ControlModel.MultiSelectionSimpleMode
1595 End If
1596 Case Else : GoTo CatchType
1597 End Select
1599 _PropertyGet = _Name
1600 Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnFocusGained"), UCase("OnFocusLost") _
1601 , UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _
1602 , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _
1603 , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnTextChanged")
1604 Set oControlEvents = _ControlModel.getEvents()
1605 sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & _GetEventName(psProperty)
1606 If oControlEvents.hasByName(sEventName) Then
1607 _PropertyGet = oControlEvents.getByName(sEventName).ScriptCode
1608 Else
1609 _PropertyGet = ""
1610 End If
1612 Select Case _ControlType
1613 Case CTLTREECONTROL
1614 _PropertyGet = _OnNodeExpanded
1615 Case Else : GoTo CatchType
1616 End Select
1618 Select Case _ControlType
1619 Case CTLTREECONTROL
1620 _PropertyGet = _OnNodeSelected
1621 Case Else : GoTo CatchType
1622 End Select
1624 If oSession.HasUnoProperty(_ControlModel, "Step") Then _PropertyGet = _ControlModel.Step
1626 Set _PropertyGet = [_Parent]
1628 Select Case _ControlType
1629 Case CTLBUTTON, CTLIMAGECONTROL
1630 If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _PropertyGet = ScriptForge.SF_FileSystem._ConvertFromUrl(_ControlModel.ImageURL)
1631 Case Else : GoTo CatchType
1632 End Select
1634 Select Case _ControlType
1635 Case CTLTREECONTROL
1636 _PropertyGet = _TreeDataModel.getRoot()
1637 Case Else : GoTo CatchType
1638 End Select
1640 Select Case _ControlType
1641 Case CTLCOMBOBOX, CTLLISTBOX
1643 If IsArray(_ControlModel.StringItemList) Then _PropertyGet = _ControlModel.StringItemList Else _PropertyGet = Array(_ControlModel.StringItemList)
1644 End If
1645 Case Else : GoTo CatchType
1646 End Select
1648 Select Case _ControlType
1649 Case CTLCOMBOBOX, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLPATTERNFIELD, CTLTEXTFIELD
1650 If oSession.HasUnoProperty(_ControlModel, "Text") Then _PropertyGet = _ControlModel.Text
1651 Case Else : GoTo CatchType
1652 End Select
1654 If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _PropertyGet = _ControlModel.HelpText
1656 Select Case _ControlType
1657 Case CTLCHECKBOX
1658 If oSession.HasUnoProperty(_ControlModel, "TriState") Then _PropertyGet = _ControlModel.TriState
1659 Case Else : GoTo CatchType
1660 End Select
1661 Case UCase("Value") ' Default values are set here by control type, not in the 2nd argument
1662 vGet = pvDefault
1663 Select Case _ControlType
1664 Case CTLBUTTON 'Boolean, toggle buttons only
1665 vGet = False
1667 If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 )
1668 End If
1670 If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = _ControlModel.State Else vGet = 2
1671 Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD 'String
1672 If oSession.HasUnoProperty(_ControlModel, "Text") Then vGet = _ControlModel.Text Else vGet = ""
1673 Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric
1674 If oSession.HasUnoProperty(_ControlModel, "Value") Then vGet = _ControlModel.Value Else vGet = 0
1675 Case CTLDATEFIELD 'Date
1676 vGet = CDate(1)
1678 If VarType(_ControlModel.Date) = ScriptForge.V_OBJECT Then ' com.sun.star.util.Date
1679 Set vDate = _ControlModel.Date
1680 vGet = DateSerial(vDate.Year, vDate.Month, vDate.Day)
1681 End If
1682 End If
1683 Case CTLFORMATTEDFIELD 'String or numeric
1684 If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then vGet = _ControlModel.EffectiveValue Else vGet = ""
1685 Case CTLLISTBOX 'String or array of strings depending on MultiSelection
1686 ' StringItemList is the list of the items displayed in the box
1687 ' SelectedItems is the list of the indexes in StringItemList of the selected items
1688 ' It can go beyond the limits of StringItemList
1689 ' It can contain multiple values even if the listbox is not multiselect
1690 If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") _
1692 vSelection = _ControlModel.SelectedItems
1693 vList = _ControlModel.StringItemList
1694 If _ControlModel.MultiSelection Then vValues = Array()
1695 For i = 0 To UBound(vSelection)
1696 lIndex = vSelection(i)
1698 If Not _ControlModel.MultiSelection Then
1699 vValues = vList(lIndex)
1700 Exit For
1701 End If
1702 vValues = ScriptForge.SF_Array.Append(vValues, vList(lIndex))
1703 End If
1704 Next i
1705 vGet = vValues
1706 Else
1707 vGet = ""
1708 End If
1709 Case CTLPROGRESSBAR 'Numeric
1710 If oSession.HasUnoProperty(_ControlModel, "ProgressValue") Then vGet = _ControlModel.ProgressValue Else vGet = 0
1711 Case CTLRADIOBUTTON 'Boolean
1712 If oSession.HasUnoProperty(_ControlModel, "State") Then vGet = ( _ControlModel.State = 1 ) Else vGet = False
1713 Case CTLSCROLLBAR 'Numeric
1714 If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then vGet = _ControlModel.ScrollValue Else vGet = 0
1715 Case CTLTABLECONTROL
1716 vGet = Array() ' Default value when no row selected, no data, multiselection
1719 ' Other selection types (multi, range) not supported
1720 If _ControlModel.SelectionModel = com.sun.star.view.SelectionType.SINGLE Then
1721 lIndex = _ControlView.CurrentRow
1724 End If
1726 End If
1727 End If
1728 Case CTLTIMEFIELD
1729 vGet = CDate(0)
1731 If VarType(_ControlModel.Time) = ScriptForge.V_OBJECT Then ' com.sun.star.Util.Time
1732 Set vDate = _ControlModel.Time
1733 vGet = TimeSerial(vDate.Hours, vDate.Minutes, vDate.Seconds)
1734 End If
1735 End If
1736 Case Else : GoTo CatchType
1737 End Select
1738 _PropertyGet = vGet
1740 If oSession.HasUnoMethod(_ControlView, "isVisible") Then _PropertyGet = CBool(_ControlView.isVisible())
1742 Set _PropertyGet = _ControlModel
1744 Set _PropertyGet = _ControlView
1746 Set _PropertyGet = _GridColumnModel
1748 Set _PropertyGet = _GridDataModel
1750 Set _PropertyGet = _TreeDataModel
1751 Case Else
1752 _PropertyGet = Null
1753 End Select
1755 Finally:
1756 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1757 Exit Function
1758 Catch:
1759 GoTo Finally
1760 CatchType:
1761 GoTo Finally
1762 End Function ' SFDialogs.SF_DialogControl._PropertyGet
1764 REM -----------------------------------------------------------------------------
1765 Private Function _PropertySet(Optional ByVal psProperty As String _
1766 , Optional ByVal pvValue As Variant _
1767 ) As Boolean
1768 ''' Set the new value of the named property
1769 ''' Args:
1770 ''' psProperty: the name of the property
1771 ''' pvValue: the new value of the given property
1773 Dim bSet As Boolean ' Return value
1774 Static oSession As Object ' Alias of SF_Session
1775 Dim vSet As Variant ' Value to set in UNO model or view property
1776 Dim vFormats As Variant ' Format property: output of _FormatsList()
1777 Dim iFormat As Integer ' Format property: index in vFormats
1778 Dim vSelection As Variant ' Alias of Model.SelectedItems
1779 Dim vList As Variant ' Alias of Model.StringItemList
1780 Dim lIndex As Long ' Index in StringItemList
1781 Dim sItem As String ' A single item
1782 Dim vCtlTypes As Variant ' Array of allowed control types
1783 Dim i As Long
1784 Dim cstThisSub As String
1787 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1788 bSet = False
1791 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
1792 If Not [_Parent]._IsStillAlive() Then GoTo Finally
1794 If IsNull(oSession) Then Set oSession = ScriptForge.SF_Services.CreateScriptService("Session")
1795 bSet = True
1796 Select Case UCase(psProperty)
1798 Select Case _ControlType
1799 Case CTLBUTTON
1800 If Not ScriptForge.SF_Utils._Validate(pvValue, "Cancel", ScriptForge.V_BOOLEAN) Then GoTo Finally
1802 If pvValue Then vSet = com.sun.star.awt.PushButtonType.CANCEL Else vSet = com.sun.star.awt.PushButtonType.STANDARD
1803 _ControlModel.PushButtonType = vSet
1804 End If
1805 Case Else : GoTo CatchType
1806 End Select
1808 Select Case _ControlType
1809 Case CTLBUTTON, CTLCHECKBOX, CTLFIXEDLINE, CTLFIXEDTEXT, CTLGROUPBOX, CTLRADIOBUTTON
1810 If Not ScriptForge.SF_Utils._Validate(pvValue, "Caption", V_STRING) Then GoTo Finally
1811 If oSession.HasUNOProperty(_ControlModel, "Label") Then _ControlModel.Label = pvValue
1812 Case Else : GoTo CatchType
1813 End Select
1815 Select Case _ControlType
1816 Case CTLTREECONTROL
1817 If Not ScriptForge.SF_Utils._Validate(pvValue, "Selection", ScriptForge.V_OBJECT) Then GoTo Finally
1818 If oSession.UnoObjectType(pvValue) <> "toolkit.MutableTreeNode" Then GoTo CatchType
1819 With _ControlView
1820 .clearSelection()
1821 If Not IsNull(pvValue) Then
1822 .addSelection(pvValue)
1823 ' Suspending temporarily the expansion listener avoids conflicts
1825 .makeNodeVisible(pvValue) ' Expand parent nodes and put node in the display area
1827 End If
1828 End With
1829 Case Else : GoTo CatchType
1830 End Select
1832 Select Case _ControlType
1833 Case CTLBUTTON
1834 If Not ScriptForge.SF_Utils._Validate(pvValue, "Default", ScriptForge.V_BOOLEAN) Then GoTo Finally
1835 If oSession.HasUNOProperty(_ControlModel, "DefaultButton") Then _ControlModel.DefaultButton = pvValue
1836 Case Else : GoTo CatchType
1837 End Select
1839 If Not ScriptForge.SF_Utils._Validate(pvValue, "Enabled", ScriptForge.V_BOOLEAN) Then GoTo Finally
1840 If oSession.HasUnoProperty(_ControlModel, "Enabled") Then _ControlModel.Enabled = pvValue
1842 Select Case _ControlType
1843 Case CTLDATEFIELD, CTLTIMEFIELD
1844 vFormats = _FormatsList()
1845 If Not ScriptForge.SF_Utils._Validate(pvValue, "Format", V_STRING, vFormats) Then GoTo Finally
1846 iFormat = ScriptForge.SF_Array.IndexOf(vFormats, pvValue, CaseSensitive := False)
1848 _ControlModel.DateFormat = iFormat
1850 _ControlModel.TimeFormat = iFormat
1851 End If
1852 Case Else : GoTo CatchType
1853 End Select
1855 If Not ScriptForge.SF_Utils._Validate(pvValue, "ListIndex", ScriptForge.V_NUMERIC) Then GoTo Finally
1856 Select Case _ControlType
1857 Case CTLCOMBOBOX
1858 If oSession.HasUNOProperty(_ControlModel, "Text") And oSession.HasUNOProperty(_ControlModel, "StringItemList") Then
1859 _ControlModel.Text = _ControlModel.StringItemList(CInt(pvValue))
1860 End If
1861 Case CTLLISTBOX
1862 If oSession.HasUNOProperty(_ControlModel, "SelectedItems") Then _ControlModel.SelectedItems = Array(CInt(pvValue))
1863 Case CTLTABLECONTROL
1866 ' Other selection types (multi, range) not supported
1867 If _ControlModel.SelectionModel = com.sun.star.view.SelectionType.SINGLE _
1869 _ControlView.selectRow(pvValue)
1870 End If
1871 End If
1872 Case Else : GoTo CatchType
1873 End Select
1875 Select Case _ControlType
1876 Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD, CTLLISTBOX _
1877 , CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD
1878 If Not ScriptForge.SF_Utils._Validate(pvValue, "Locked", ScriptForge.V_BOOLEAN) Then GoTo Finally
1879 If oSession.HasUnoProperty(_ControlModel, "ReadOnly") Then _ControlModel.ReadOnly = pvValue
1880 Case Else : GoTo CatchType
1881 End Select
1883 Select Case _ControlType
1884 Case CTLLISTBOX
1885 If Not ScriptForge.SF_Utils._Validate(pvValue, "MultiSelect", ScriptForge.V_BOOLEAN) Then GoTo Finally
1886 If oSession.HasUnoProperty(_ControlModel, "MultiSelection") Then _ControlModel.MultiSelection = pvValue
1887 If oSession.HasUnoProperty(_ControlModel, "MultiSelectionSimpleMode") Then _ControlModel.MultiSelectionSimpleMode = pvValue
1889 If Not pvValue And UBound(_ControlModel.SelectedItems) > 0 Then ' Cancel selections when MultiSelect becomes False
1890 lIndex = _ControlModel.SelectedItems(0)
1891 _ControlModel.SelectedItems = Array(lIndex)
1892 End If
1893 End If
1894 Case Else : GoTo CatchType
1895 End Select
1897 Select Case _ControlType
1898 Case CTLTREECONTROL
1899 If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then GoTo Finally
1900 ' If the listener was already set, then stop it
1902 _ControlView.removeTreeExpansionListener(_ExpandListener)
1903 Set _ExpandListener = Nothing
1904 _OnNodeExpanded = ""
1905 End If
1906 ' Setup a new fresh listener
1908 Set _ExpandListener = CreateUnoListener("_SFEXP_", "com.sun.star.awt.tree.XTreeExpansionListener")
1909 _ControlView.addTreeExpansionListener(_ExpandListener)
1910 _OnNodeExpanded = pvValue
1911 End If
1912 Case Else : GoTo CatchType
1913 End Select
1915 Select Case _ControlType
1916 Case CTLTREECONTROL
1917 If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then GoTo Finally
1918 ' If the listener was already set, then stop it
1920 _ControlView.removeSelectionChangeListener(_SelectListener)
1921 Set _SelectListener = Nothing
1922 _OnNodeSelected = ""
1923 End If
1924 ' Setup a new fresh listener
1926 Set _SelectListener = CreateUnoListener("_SFSEL_", "com.sun.star.view.XSelectionChangeListener")
1927 _ControlView.addSelectionChangeListener(_SelectListener)
1928 _OnNodeSelected = pvValue
1929 End If
1930 Case Else : GoTo CatchType
1931 End Select
1933 If Not ScriptForge.SF_Utils._Validate(pvValue, "Page", ScriptForge.V_NUMERIC) Then GoTo Finally
1934 If oSession.HasUnoProperty(_ControlModel, "Step") Then _ControlModel.Step = CLng(pvValue)
1936 Select Case _ControlType
1937 Case CTLBUTTON, CTLIMAGECONTROL
1939 If oSession.HasUnoProperty(_ControlModel, "ImageURL") Then _ControlModel.ImageURL = ScriptForge.SF_FileSystem._ConvertToUrl(pvValue)
1940 Case Else : GoTo CatchType
1941 End Select
1943 Select Case _ControlType
1944 Case CTLCOMBOBOX, CTLLISTBOX
1945 If Not IsArray(pvValue) Then
1946 If Not ScriptForge.SF_Utils._Validate(pvValue, "RowSource", V_STRING) Then GoTo Finally
1947 pvArray = Array(pvArray)
1948 ElseIf Not ScriptForge.SF_Utils._ValidateArray(pvValue, "RowSource", 1, V_STRING, True) Then
1949 GoTo Finally
1950 End If
1951 If oSession.HasUnoProperty(_ControlModel, "StringItemList") Then _ControlModel.StringItemList = pvValue
1952 Case Else : GoTo CatchType
1953 End Select
1955 If Not ScriptForge.SF_Utils._Validate(pvValue, "TipText", V_STRING) Then GoTo Finally
1956 If oSession.HasUnoProperty(_ControlModel, "HelpText") Then _ControlModel.HelpText = pvValue
1958 Select Case _ControlType
1959 Case CTLCHECKBOX
1960 If Not ScriptForge.SF_Utils._Validate(pvValue, "TripleState", ScriptForge.V_BOOLEAN) Then GoTo Finally
1961 If oSession.HasUnoProperty(_ControlModel, "TriState") Then _ControlModel.TriState = pvValue
1962 Case Else : GoTo CatchType
1963 End Select
1965 Select Case _ControlType
1966 Case CTLBUTTON 'Boolean, toggle buttons only
1967 If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally
1968 If oSession.HasUnoProperty(_ControlModel, "Toggle") And oSession.HasUnoProperty(_ControlModel, "State") Then
1970 End If
1972 If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(ScriptForge.V_BOOLEAN, ScriptForge.V_NUMERIC), Array(0, 1, 2, True, False)) Then GoTo Finally
1975 _ControlModel.State = pvValue
1976 End If
1977 Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD 'String
1980 Case CTLCURRENCYFIELD, CTLNUMERICFIELD 'Numeric
1981 If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally
1982 If oSession.HasUnoProperty(_ControlModel, "Value") Then _ControlModel.Value = pvValue
1983 Case CTLDATEFIELD 'Date
1986 Set vSet = New com.sun.star.util.Date
1987 vSet.Year = Year(pvValue)
1988 vSet.Month = Month(pvValue)
1989 vSet.Day = Day(pvValue)
1990 _ControlModel.Date = vSet
1991 End If
1992 Case CTLFORMATTEDFIELD 'String or numeric
1993 If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", Array(V_STRING, ScriptForge.V_NUMERIC)) Then GoTo Finally
1994 If oSession.HasUnoProperty(_ControlModel, "EffectiveValue") Then _ControlModel.EffectiveValue = pvValue
1995 Case CTLLISTBOX 'String or array of strings depending on MultiSelection
1996 ' StringItemList is the list of the items displayed in the box
1997 ' SelectedItems is the list of the indexes in StringItemList of the selected items
1998 ' It can go beyond the limits of StringItemList
1999 ' It can contain multiple values even if the listbox is not multiselect
2000 If oSession.HasUnoProperty(_ControlModel, "StringItemList") And oSession.HasUnoProperty(_ControlModel, "SelectedItems") _
2002 vSelection = Array()
2003 If _ControlModel.MultiSelection Then
2004 If Not ScriptForge.SF_Utils._ValidateArray(pvValue, "Value", 1, V_STRING, True) Then GoTo Finally
2005 vList = _ControlModel.StringItemList
2006 For i = LBound(pvValue) To UBound(pvValue)
2007 sItem = pvValue(i)
2008 lIndex = ScriptForge.SF_Array.IndexOf(vList, sItem)
2010 Next i
2011 Else
2013 lIndex = ScriptForge.SF_Array.IndexOf(_ControlModel.StringItemList, pvValue)
2015 End If
2016 _ControlModel.SelectedItems = vSelection
2017 End If
2018 Case CTLPROGRESSBAR 'Numeric
2019 If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally
2021 If pvValue < _ControlModel.ProgressValueMin Then pvValue = _ControlModel.ProgressValueMin
2022 End If
2024 If pvValue > _ControlModel.ProgressValueMax Then pvValue = _ControlModel.ProgressValueMax
2025 End If
2026 If oSession.HasUnoProperty(_ControlModel, "ProgressValue") Then _ControlModel.ProgressValue = pvValue
2027 Case CTLRADIOBUTTON 'Boolean
2028 If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_BOOLEAN) Then GoTo Finally
2029 If oSession.HasUnoProperty(_ControlModel, "State") Then _ControlModel.State = Iif(pvValue, 1, 0)
2030 Case CTLSCROLLBAR 'Numeric
2031 If Not ScriptForge.SF_Utils._Validate(pvValue, "Value", ScriptForge.V_NUMERIC) Then GoTo Finally
2033 If pvValue < _ControlModel.ScrollValueMin Then pvValue = _ControlModel.ScrollValueMin
2034 End If
2036 If pvValue > _ControlModel.ScrollValueMax Then pvValue = _ControlModel.ScrollValueMax
2037 End If
2038 If oSession.HasUnoProperty(_ControlModel, "ScrollValue") Then _ControlModel.ScrollValue = pvValue
2039 Case CTLTIMEFIELD
2042 Set vSet = New com.sun.star.util.Time
2043 vSet.Hours = Hour(pvValue)
2044 vSet.Minutes = Minute(pvValue)
2045 vSet.Seconds = Second(pvValue)
2046 _ControlModel.Time = vSet
2047 End If
2048 Case Else : GoTo CatchType
2049 End Select
2051 If Not ScriptForge.SF_Utils._Validate(pvValue, "Visible", ScriptForge.V_BOOLEAN) Then GoTo Finally
2053 If pvValue Then
2054 If oSession.HasUnoProperty(_ControlModel, "EnableVisible") Then _ControlModel.EnableVisible = True
2055 End If
2056 _ControlView.setVisible(pvValue)
2057 End If
2058 Case Else
2059 bSet = False
2060 End Select
2062 Finally:
2063 _PropertySet = bSet
2064 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
2065 Exit Function
2066 Catch:
2067 GoTo Finally
2068 CatchType:
2069 ScriptForge.SF_Exception.RaiseFatal(CONTROLTYPEERROR, _Name, _DialogName, _ControlType, psProperty)
2070 GoTo Finally
2071 End Function ' SFDialogs.SF_DialogControl._PropertySet
2073 REM -----------------------------------------------------------------------------
2074 Private Function _Repr() As String
2075 ''' Convert the Model instance to a readable string, typically for debugging purposes (DebugPrint ...)
2076 ''' Args:
2077 ''' Return:
2078 ''' "[DIALOGCONTROL]: Name, Type (dialogname)
2079 _Repr = "[DIALOGCONTROL]: " & _Name & ", " & _ControlType & " (" & _DialogName & ")"
2081 End Function ' SFDialogs.SF_DialogControl._Repr
2083 REM ============================================ END OF SFDIALOGS.SF_DIALOGCONTROL
2084 </script:module>