Current File : //usr/lib/libreoffice/share/basic/SFDialogs/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
' Control initial position and dimensions in APPFONT units
Private _Left As Long
Private _Top As Long
Private _Width As Long
Private _Height As Long
' 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
' Updatable events
Private _ActionListener As Object ' com.sun.star.awt.XActionListener
Private _OnActionPerformed As String ' Script to invoke when action triggered
Private _ActionCounter As Integer ' Counts the number of events set on the listener
' ---
Private _AdjustmentListener As Object ' com.sun.star.awt.XAdjustmentListener
Private _OnAdjustmentValueChanged As String ' Script to invoke when scrollbar value has changed
Private _AdjustmentCounter As Integer ' Counts the number of events set on the listener
' ---
Private _FocusListener As Object ' com.sun.star.awt.XFocusListener
Private _OnFocusGained As String ' Script to invoke when control gets focus
Private _OnFocusLost As String ' Script to invoke when control loses focus
Private _FocusCounter As Integer ' Counts the number of events set on the listener
' ---
Private _ItemListener As Object ' com.sun.star.awt.XItemListener
Private _OnItemStateChanged As String ' Script to invoke when status of item changes
Private _ItemCounter As Integer ' Counts the number of events set on the listener
' ---
Private _KeyListener As Object ' com.sun.star.awt.XKeyListener
Private _OnKeyPressed As String ' Script to invoke when Key clicked in control
Private _OnKeyReleased As String ' Script to invoke when Key released in control
Private _KeyCounter As Integer ' Counts the number of events set on the listener
' ---
Private _MouseListener As Object ' com.sun.star.awt.XMouseListener
Private _OnMouseEntered As String ' Script to invoke when mouse enters control
Private _OnMouseExited As String ' Script to invoke when mouse leaves control
Private _OnMousePressed As String ' Script to invoke when mouse clicked in control
Private _OnMouseReleased As String ' Script to invoke when mouse released in control
Private _MouseCounter As Integer ' Counts the number of events set on the listener
' ---
Private _MouseMotionListener As Object ' com.sun.star.awt.XMouseMotionListener
Private _OnMouseDragged As String ' Script to invoke when mouse is dragged from the control
Private _OnMouseMoved As String ' Script to invoke when mouse is moved across the control
Private _MouseMotionCounter As Integer ' Counts the number of events set on the listener
' ---
Private _TextListener As Object ' com.sun.star.awt.XTextListener
Private _OnTextChanged As String ' Script to invoke when textual content has changed
Private _TextCounter As Integer ' Counts the number of events set on the listener
' 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 CTLHYPERLINK = "Hyperlink"
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 = ""
_Left = SF_DialogUtils.MINPOSITION
_Top = SF_DialogUtils.MINPOSITION
_Width = -1
_Height = -1
_OnNodeSelected = ""
_OnNodeExpanded = ""
Set _SelectListener = Nothing
Set _ExpandListener = Nothing
Set _ActionListener = Nothing
_OnActionPerformed = ""
_ActionCounter = 0
Set _AdjustmentListener = Nothing
_OnAdjustmentValueChanged = ""
_AdjustmentCounter = 0
Set _FocusListener = Nothing
_OnFocusGained = ""
_OnFocusLost = ""
_FocusCounter = 0
Set _KeyListener = Nothing
_OnKeyPressed = ""
_OnKeyReleased = ""
_KeyCounter = 0
Set _MouseListener = Nothing
_OnMouseEntered = ""
_OnMouseExited = ""
_OnMousePressed = ""
_OnMouseReleased = ""
_MouseCounter = 0
Set _MouseMotionListener = Nothing
_OnMouseDragged = ""
_OnMouseMoved = ""
_MouseMotionCounter = 0
Set _ItemListener = Nothing
_OnItemStateChanged = ""
_ItemCounter = 0
Set _TextListener = Nothing
_OnTextChanged = ""
_TextCounter = 0
_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 Border() As Variant
''' The Border property refers to the surrounding of the control: 3D, FLAT or NONE
Border = _PropertyGet("Border", "")
End Property ' SFDialogs.SF_DialogControl.Border (get)
REM -----------------------------------------------------------------------------
Property Let Border(Optional ByVal pvBorder As Variant)
''' Set the updatable property Border
_PropertySet("Border", pvBorder)
End Property ' SFDialogs.SF_DialogControl.Border (let)
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
_PropertySet("Format", pvFormat)
End Property ' SFDialogs.SF_DialogControl.Format (let)
REM -----------------------------------------------------------------------------
Property Get Height() As Variant
''' The Height property refers to the height of the control
Height = _PropertyGet("Height")
End Property ' SFDialogs.SF_DialogControl.Height (get)
REM -----------------------------------------------------------------------------
Property Let Height(Optional ByVal pvHeight As Variant)
''' Set the updatable property Height
_PropertySet("Height", pvHeight)
End Property ' SFDialogs.SF_DialogControl.Height (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 Let OnActionPerformed(Optional ByVal pvActionPerformed As Variant)
''' Set the updatable property OnActionPerformed
_PropertySet("OnActionPerformed", pvActionPerformed)
End Property ' SFDialogs.SF_DialogControl.OnActionPerformed (let)
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 Let OnAdjustmentValueChanged(Optional ByVal pvAdjustmentValueChanged As Variant)
''' Set the updatable property OnAdjustmentValueChanged
_PropertySet("OnAdjustmentValueChanged", pvAdjustmentValueChanged)
End Property ' SFDialogs.SF_DialogControl.OnAdjustmentValueChanged (let)
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 Let OnFocusGained(Optional ByVal pvOnFocusGained As Variant)
''' Set the updatable property OnFocusGained
_PropertySet("OnFocusGained", pvOnFocusGained)
End Property ' SFDialogs.SF_DialogControl.OnFocusGained (let)
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 Let OnFocusLost(Optional ByVal pvOnFocusLost As Variant)
''' Set the updatable property OnFocusLost
_PropertySet("OnFocusLost", pvOnFocusLost)
End Property ' SFDialogs.SF_DialogControl.OnFocusLost (let)
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 Let OnItemStateChanged(Optional ByVal pvItemStateChanged As Variant)
''' Set the updatable property OnItemStateChanged
_PropertySet("OnItemStateChanged", pvItemStateChanged)
End Property ' SFDialogs.SF_DialogControl.OnItemStateChanged (let)
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 Let OnKeyPressed(Optional ByVal pvOnKeyPressed As Variant)
''' Set the updatable property OnKeyPressed
_PropertySet("OnKeyPressed", pvOnKeyPressed)
End Property ' SFDialogs.SF_DialogControl.OnKeyPressed (let)
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 Let OnKeyReleased(Optional ByVal pvOnKeyReleased As Variant)
''' Set the updatable property OnKeyReleased
_PropertySet("OnKeyReleased", pvOnKeyReleased)
End Property ' SFDialogs.SF_DialogControl.OnKeyReleased (let)
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 Let OnMouseDragged(Optional ByVal pvOnMouseDragged As Variant)
''' Set the updatable property OnMouseDragged
_PropertySet("OnMouseDragged", pvOnMouseDragged)
End Property ' SFDialogs.SF_DialogControl.OnMouseDragged (let)
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 Let OnMouseEntered(Optional ByVal pvOnMouseEntered As Variant)
''' Set the updatable property OnMouseEntered
_PropertySet("OnMouseEntered", pvOnMouseEntered)
End Property ' SFDialogs.SF_DialogControl.OnMouseEntered (let)
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 Let OnMouseExited(Optional ByVal pvOnMouseExited As Variant)
''' Set the updatable property OnMouseExited
_PropertySet("OnMouseExited", pvOnMouseExited)
End Property ' SFDialogs.SF_DialogControl.OnMouseExited (let)
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 Let OnMouseMoved(Optional ByVal pvOnMouseMoved As Variant)
''' Set the updatable property OnMouseMoved
_PropertySet("OnMouseMoved", pvOnMouseMoved)
End Property ' SFDialogs.SF_DialogControl.OnMouseMoved (let)
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 Let OnMousePressed(Optional ByVal pvOnMousePressed As Variant)
''' Set the updatable property OnMousePressed
_PropertySet("OnMousePressed", pvOnMousePressed)
End Property ' SFDialogs.SF_DialogControl.OnMousePressed (let)
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 Let OnMouseReleased(Optional ByVal pvOnMouseReleased As Variant)
''' Set the updatable property OnMouseReleased
_PropertySet("OnMouseReleased", pvOnMouseReleased)
End Property ' SFDialogs.SF_DialogControl.OnMouseReleased (let)
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 Let OnTextChanged(Optional ByVal pvTextChanged As Variant)
''' Set the updatable property OnTextChanged
_PropertySet("OnTextChanged", pvTextChanged)
End Property ' SFDialogs.SF_DialogControl.OnTextChanged (let)
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 TabIndex() As Variant
''' The TabIndex property specifies a control's place in the tab order in the dialog
''' Zero or negative means no tab set in the control
TabIndex = _PropertyGet("TabIndex", -1)
End Property ' SFDialogs.SF_DialogControl.TabIndex (get)
REM -----------------------------------------------------------------------------
Property Let TabIndex(Optional ByVal pvTabIndex As Variant)
''' Set the updatable property TabIndex
_PropertySet("TabIndex", pvTabIndex)
End Property ' SFDialogs.SF_DialogControl.TabIndex (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 URL() As Variant
''' The URL property refers to the URL to open when the control is clicked
URL = _PropertyGet("URL", "")
End Property ' SFDialogs.SF_DialogControl.URL (get)
REM -----------------------------------------------------------------------------
Property Let URL(Optional ByVal pvURL As Variant)
''' Set the updatable property URL
_PropertySet("URL", pvURL)
End Property ' SFDialogs.SF_DialogControl.URL (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 Width() As Variant
''' The Width property refers to the Width of the control
Width = _PropertyGet("Width")
End Property ' SFDialogs.SF_DialogControl.Width (get)
REM -----------------------------------------------------------------------------
Property Let Width(Optional ByVal pvWidth As Variant)
''' Set the updatable property Width
_PropertySet("Width", pvWidth)
End Property ' SFDialogs.SF_DialogControl.Width (let)
REM -----------------------------------------------------------------------------
Property Get X() As Variant
''' The X property refers to the X coordinate of the top-left corner of the control
X = _PropertyGet("X")
End Property ' SFDialogs.SF_DialogControl.X (get)
REM -----------------------------------------------------------------------------
Property Let X(Optional ByVal pvX As Variant)
''' Set the updatable property X
_PropertySet("X", pvX)
End Property ' SFDialogs.SF_DialogControl.X (let)
REM -----------------------------------------------------------------------------
Property Get Y() As Variant
''' The Y property refers to the Y coordinate of the top-left corner of the control
Y = _PropertyGet("Y")
End Property ' SFDialogs.SF_DialogControl.Y (get)
REM -----------------------------------------------------------------------------
Property Let Y(Optional ByVal pvY As Variant)
''' Set the updatable property Y
_PropertySet("Y", pvY)
End Property ' SFDialogs.SF_DialogControl.Y (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( _
"Border" _
, "Cancel" _
, "Caption" _
, "ControlType" _
, "CurrentNode" _
, "Default" _
, "Enabled" _
, "Format" _
, "Height" _
, "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" _
, "TabIndex" _
, "Text" _
, "TipText" _
, "TripleState" _
, "URL" _
, "Value" _
, "Visible" _
, "Width" _
, "X" _
, "XControlModel" _
, "XControlView" _
, "XGridColumnModel" _
, "XGridDataModel" _
, "XTreeDataModel" _
, "Y" _
)
End Function ' SFDialogs.SF_DialogControl.Properties
REM -----------------------------------------------------------------------------
Public Function Resize(Optional ByVal Left As Variant _
, Optional ByVal Top As Variant _
, Optional ByVal Width As Variant _
, Optional ByVal Height As Variant _
) As Boolean
''' Move the top-left corner of the control to new coordinates and/or modify its dimensions
''' Without arguments, the method resets the initial dimensions and position
''' Attributes denoting the position and size of a control are expressed in "Map AppFont" units.
''' Map AppFont units are device and resolution independent.
''' One Map AppFont unit is equal to one eighth of the average character (Systemfont) height and one quarter of the average character width.
''' The dialog editor (= the Basic IDE) also uses Map AppFont units.
''' Args:
''' Left : the horizontal distance from the top-left corner. It may be negative.
''' Top : the vertical distance from the top-left corner. It may be negative.
''' Width : the horizontal width of the rectangle containing the Dialog. It must be positive.
''' Height : the vertical height of the rectangle containing the Dialog. It must be positive.
''' Missing arguments are left unchanged.
''' Returns:
''' True when successful
''' Examples:
''' myControl.Resize(100, 200, Height := 600) ' Width is not changed
Try:
Resize = SF_DialogUtils._Resize([Me], Left, Top, Width, Height)
End Function ' SFDialogss.SF_Dialog.Resize
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 _
, Optional ByVal RowHeaderWidth 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 one data 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 available space in 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)
''' RowGeaderWidth: width of the row header column expressed in AppFont units. Default = 10.
''' The argument is ignored when the TableControl has no row header.
''' 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 lHeaderWidth As Long ' Row header width when row header present, otherwise = 0
Dim lAverageWidth As Long ' Width to apply when columns spread evenly across table
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 cstThisSub = "SFDialogs.DialogControl.SetTableData"
Const cstSubArgs = "DataArray, [Widths=Array(1)], [Alignments=""""], [RowHeaderWidth=10]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
bData = False
Check:
If IsMissing(Widths) Or IsEmpty(Widths) Then Widths = Array()
If IsMissing(Alignments) Or IsEmpty(Alignments) Then Alignments = ""
If IsMissing(RowHeaderWidth) Or IsEmpty(RowHeaderWidth) Then RowHeaderWidth = 10
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
If Not ScriptForge.SF_Utils._Validate(RowHeaderWidth, "RowHeaderWidth", ScriptForge.V_NUMERIC) 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 Python
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
' Manage row headers width
If _ControlModel.ShowRowHeader Then
lHeaderWidth = RowHeaderWidth
_ControlModel.RowHeaderWidth = lHeaderWidth
Else
lHeaderWidth = 0
End If
' 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 column widths
If dRelativeWidth > 0.0 Then dWidthFactor = CDbl(_ControlModel.Width - lHeaderWidth) / 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 header and columns evenly
lAverageWidth = (_ControlModel.Width - lHeaderWidth) / (lMax2 - lMin2 + 1)
For j = 0 To lMax2 - lMinCol
_GridColumnModel.Columns(j).ColumnWidth = lAverageWidth
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 -----------------------------------------------------------------------------
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 "UnoControlFixedHyperlinkModel"
_ControlType = CTLHYPERLINK
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 initial position and dimensions
With _ControlModel
_Left = .PositionX
_Top = .PositionY
_Width = .Width
_Height = .Height
End With
' 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 oPosSize As Object ' com.sun.star.awt.Rectangle
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("Border")
Select Case _ControlType
Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFIXEDTEXT, CTLFORMATTEDFIELD _
, CTLHYPERLINK, CTLIMAGECONTROL, CTLLISTBOX, CTLNUMERICFIELD, CTLPATTERNFIELD, CTLPROGRESSBAR _
, CTLSCROLLBAR , CTLTABLECONTROL, CTLTEXTFIELD, CTLTIMEFIELD, CTLTREECONTROL
If oSession.HasUNOProperty(_ControlModel, "Border") Then _PropertyGet = Array("NONE", "3D", "FLAT")(_ControlModel.Border)
Case CTLCHECKBOX, CTLRADIOBUTTON
If oSession.HasUNOProperty(_ControlModel, "VisualEffect") Then _PropertyGet = Array("NONE", "3D", "FLAT")(_ControlModel.VisualEffect)
Case Else : GoTo CatchType
End Select
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, CTLHYPERLINK, 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 = SF_DialogUtils._FormatsList(_ControlType)(_ControlModel.DateFormat)
Case CTLTIMEFIELD
If oSession.HasUNOProperty(_ControlModel, "TimeFormat") Then _PropertyGet = SF_DialogUtils._FormatsList(_ControlType)(_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("Height")
If [_parent]._Displayed Then ' Convert PosSize view property from pixels to APPFONT units
_PropertyGet = SF_DialogUtils._ConvertToAppFont(_ControlView, False).Height
Else
If oSession.HasUNOProperty(_ControlModel, "Height") Then _PropertyGet = _ControlModel.Height
End If
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
' Check OnEvents set dynamically by code
Select Case UCase(psProperty)
Case UCase("OnActionPerformed") : _PropertyGet = _OnActionPerformed
Case UCase("OnAdjustmentValueChanged") : _PropertyGet = _OnAdjustmentValueChanged
Case UCase("OnFocusGained") : _PropertyGet = _OnFocusGained
Case UCase("OnFocusLost") : _PropertyGet = _OnFocusLost
Case UCase("OnItemStateChanged") : _PropertyGet = _OnItemStateChanged
Case UCase("OnKeyPressed") : _PropertyGet = _OnKeyPressed
Case UCase("OnKeyReleased") : _PropertyGet = _OnKeyReleased
Case UCase("OnMouseDragged") : _PropertyGet = _OnMouseDragged
Case UCase("OnMouseEntered") : _PropertyGet = _OnMouseEntered
Case UCase("OnMouseExited") : _PropertyGet = _OnMouseExited
Case UCase("OnMouseMoved") : _PropertyGet = _OnMouseMoved
Case UCase("OnMousePressed") : _PropertyGet = _OnMousePressed
Case UCase("OnMouseReleased") : _PropertyGet = _OnMouseReleased
Case UCase("OnTextChanged") : _PropertyGet = _OnTextChanged
Case Else : _PropertyGet = ""
End Select
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("TabIndex")
Select Case _ControlType
Case CTLBUTTON, CTLCHECKBOX, CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFIXEDTEXT _
, CTLFORMATTEDFIELD, CTLHYPERLINK, CTLIMAGECONTROL, CTLLISTBOX, CTLNUMERICFIELD, CTLPATTERNFIELD _
, CTLRADIOBUTTON, CTLSCROLLBAR, CTLTABLECONTROL, CTLTEXTFIELD, CTLTIMEFIELD, CTLTREECONTROL
If oSession.HasUnoProperty(_ControlModel, "TabIndex") Then
If CBool(_ControlModel.TabStop) Or IsEmpty(_ControlModel.TabStop) Then _PropertyGet = _ControlModel.TabIndex Else _PropertyGet = -1
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 "URL"
Select Case _ControlType
Case CTLHYPERLINK
If oSession.HasUnoProperty(_ControlModel, "URL") Then _PropertyGet = _ControlModel.URL
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") And _ControlMOdel.Toggle 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("Width")
If [_parent]._Displayed Then ' Convert PosSize view property from pixels to APPFONT units
_PropertyGet = SF_DialogUtils._ConvertToAppFont(_ControlView, False).Width
Else
If oSession.HasUNOProperty(_ControlModel, "Width") Then _PropertyGet = _ControlModel.Width
End If
Case UCase("X")
If [_parent]._Displayed Then ' Convert PosSize view property from pixels to APPFONT units
_PropertyGet = SF_DialogUtils._ConvertToAppFont(_ControlView, True).X
Else
If oSession.HasUNOProperty(_ControlModel, "PositionX") Then _PropertyGet = _ControlModel.PositionX
End If
Case UCase("Y")
If [_parent]._Displayed Then ' Convert PosSize view property from pixels to APPFONT units
_PropertyGet = SF_DialogUtils._ConvertToAppFont(_ControlView, True).Y
Else
If oSession.HasUNOProperty(_ControlModel, "PositionY") Then _PropertyGet = _ControlModel.PositionY
End If
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 vBorders As Variant ' Array of allowed Border values
Dim vFormats As Variant ' Format property: output of _FormatsList()
Dim iFormat As Integer ' Format property: index in vFormats
Dim oNumberFormats As Object ' com.sun.star.util.XNumberFormats
Dim lFormatKey As Long ' Format index for formatted fields
Dim oLocale As Object ' com.sun.star.lang.Locale
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("Border")
Select Case _ControlType
Case CTLCHECKBOX, CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFIXEDTEXT, CTLFORMATTEDFIELD _
, CTLHYPERLINK, CTLIMAGECONTROL, CTLLISTBOX, CTLNUMERICFIELD, CTLPATTERNFIELD, CTLPROGRESSBAR _
, CTLRADIOBUTTON, CTLSCROLLBAR , CTLTABLECONTROL, CTLTEXTFIELD, CTLTIMEFIELD, CTLTREECONTROL
vBorders = Array("NONE", "3D", "FLAT")
If Not ScriptForge.SF_Utils._Validate(pvValue, "Border", V_STRING, vBorders) Then GoTo Finally
vSet = ScriptForge.SF_Array.IndexOf(vBorders, pvValue)
If oSession.HasUNOProperty(_ControlModel, "Border") Then
_ControlModel.Border = vSet
ElseIf oSession.HasUNOProperty(_ControlModel, "VisualEffect") Then ' Checkbox case
_ControlModel.VisualEffect = vSet
End If
Case Else : GoTo CatchType
End Select
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, CTLHYPERLINK, 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 = SF_DialogUtils._FormatsList(_ControlType)
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 CTLFORMATTEDFIELD ' The format may exist already or not yet
If Not ScriptForge.SF_Utils._Validate(pvValue, "Format", V_STRING) Then GoTo Finally
If oSession.HasUNOProperty(_ControlModel, "FormatsSupplier") Then
If Not IsNull(_ControlModel.FormatsSupplier) Then
Set oLocale = ScriptForge.SF_Utils._GetUnoService("FormatLocale")
Set oNumberFormats = _ControlModel.FormatsSupplier.getNumberFormats()
lFormatKey = oNumberFormats.queryKey(pvValue, oLocale, True)
If lFormatKey < 0 Then ' Format not found
_ControlModel.FormatKey = oNumberFormats.addNew(pvValue, oLocale)
Else
_ControlModel.FormatKey = lFormatKey
End If
End If
End If
Case Else : GoTo CatchType
End Select
Case UCase("Height")
If Not ScriptForge.SF_Utils._Validate(pvValue, "Height", ScriptForge.V_NUMERIC) Then GoTo Catch
bSet = Resize(Height := pvValue)
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("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")
If Not ScriptForge.SF_Utils._Validate(pvValue, psProperty, V_STRING) Then GoTo Catch
' Check control type for not universal event types
Select Case UCase(psProperty)
Case UCase("OnActionPerformed"), UCase("OnItemStateChanged")
Select Case _ControlType
Case CTLBUTTON, CTLCHECKBOX, CTLCOMBOBOX, CTLHYPERLINK, CTLLISTBOX, CTLRADIOBUTTON
Case Else : GoTo CatchType
End Select
Case UCase("OnAdjustmentValueChanged")
If _ControlType <> CTLSCROLLBAR Then GoTo CatchType
Case UCase("OnTextChanged")
Select Case _ControlType
Case CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFORMATTEDFIELD _
, CTLNUMERICFIELD, CTLPATTERNFIELD, CTLTEXTFIELD, CTLTIMEFIELD, CTLTREECONTROL
Case Else : GoTo CatchType
End Select
Case Else
End Select
bSet = SF_DialogListener._SetOnProperty([Me], psProperty, pvValue)
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("TabIndex")
Select Case _ControlType
Case CTLBUTTON, CTLCHECKBOX, CTLCOMBOBOX, CTLCURRENCYFIELD, CTLDATEFIELD, CTLFILECONTROL, CTLFIXEDTEXT _
, CTLFORMATTEDFIELD, CTLHYPERLINK, CTLIMAGECONTROL, CTLLISTBOX, CTLNUMERICFIELD, CTLPATTERNFIELD _
, CTLRADIOBUTTON, CTLSCROLLBAR, CTLTABLECONTROL, CTLTEXTFIELD, CTLTIMEFIELD, CTLTREECONTROL
If Not ScriptForge.SF_Utils._Validate(pvValue, "TabIndex", ScriptForge.V_NUMERIC) Then GoTo Finally
If oSession.HasUnoProperty(_ControlModel, "TabIndex") Then
_ControlModel.TabStop = ( pvValue > 0 )
_ControlModel.TabIndex = Iif(pvValue > 0, pvValue, -1)
End If
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 "URL"
Select Case _ControlType
Case CTLHYPERLINK
If Not ScriptForge.SF_Utils._Validate(pvValue, "URL", V_STRING) Then GoTo Finally
If oSession.HasUnoProperty(_ControlModel, "URL") Then _ControlModel.URL = 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
If _ControlModel.Toggle Then _ControlModel.State = Iif(pvValue, 1, 0) Else _ControlModel.State = 2
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 UCase("Width")
If Not ScriptForge.SF_Utils._Validate(pvValue, "Width", ScriptForge.V_NUMERIC) Then GoTo Catch
bSet = Resize(Width := pvValue)
Case "X"
If Not ScriptForge.SF_Utils._Validate(pvValue, "Width", ScriptForge.V_NUMERIC) Then GoTo Catch
bSet = Resize(Left := pvValue)
Case "Y"
If Not ScriptForge.SF_Utils._Validate(pvValue, "Width", ScriptForge.V_NUMERIC) Then GoTo Catch
bSet = Resize(Top := pvValue)
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>
Mini Shell