REM ======================================================================================================================= REM === The Access2Base library is a part of the LibreOffice project. === REM === Full documentation is available on http://www.access2base.com === REM ======================================================================================================================= Option Compatible Option ClassModule Option Explicit REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- Private _Type As String ' Must be CONTROL Private _This As Object ' Workaround for absence of This builtin function Private _Parent As Object Private _ImplementationName As String Private _ClassId As Integer Private _ParentType As String ' One of CTLPARENTISxxxx constants Private _Shortcut As String Private _Name As String Private _FormComponent As Object ' com.sun.star.text.TextDocument Private _MainForm As String ' To be propagated to all subcontrols Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure Private _DbEntry As Integer Private _ControlType As Integer Private _ThisProperties As Variant ' Buffer for properties list Private _SubType As String Private ControlModel As Object ' com.sun.star.comp.forms.XXXModel Private ControlView As Object ' com.sun.star.comp.forms.XXXControl (NULL if form open in edit mode) Private BoundField As Object ' com.sun.star.sdb.ODataColumn Private LabelControl As Object ' com.sun.star.form.component.FixedText or com.sun.star.form.component.GroupBox REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJCONTROL Set _This = Nothing Set _Parent = Nothing _ClassId = -1 _ParentType = "" _Shortcut = "" _Name = "" Set _FormComponent = Nothing _MainForm = "" _DocEntry = -1 _DbEntry = -1 _ThisProperties = Array() _SubType = "" Set ControlModel = Nothing Set ControlView = Nothing Set BoundField = Nothing Set LabelControl = Nothing End Sub ' Constructor REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Terminate() On Local Error Resume Next Call Class_Initialize() End Sub ' Destructor REM ----------------------------------------------------------------------------------------------------------------------- Public Sub Dispose() Call Class_Terminate() End Sub ' Explicit destructor REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS GET/LET/SET PROPERTIES --- REM ----------------------------------------------------------------------------------------------------------------------- Property Get BackColor() As Variant BackColor = _PropertyGet("BackColor") End Property ' BackColor (get) Property Let BackColor(ByVal pvValue As Variant) Call _PropertySet("BackColor", pvValue) End Property ' BackColor (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get BorderColor() As Variant BorderColor = _PropertyGet("BorderColor") End Property ' BorderColor (get) Property Let BorderColor(ByVal pvValue As Variant) Call _PropertySet("BorderColor", pvValue) End Property ' BorderColor (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get BorderStyle() As Variant BorderStyle = _PropertyGet("BorderStyle") End Property ' BorderStyle (get) Property Let BorderStyle(ByVal pvValue As Variant) Call _PropertySet("BorderStyle", pvValue) End Property ' BorderStyle (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Cancel() As Variant Cancel = _PropertyGet("Cancel") End Property ' Cancel (get) Property Let Cancel(ByVal pvValue As Variant) Call _PropertySet("Cancel", pvValue) End Property ' Cancel (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Caption() As Variant Caption = _PropertyGet("Caption") End Property ' Caption (get) Property Let Caption(ByVal pvValue As Variant) Call _PropertySet("Caption", pvValue) End Property ' Caption (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ControlSource() As Variant ControlSource = _PropertyGet("ControlSource") End Property ' ControlSource (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ControlTipText() As Variant ControlTipText = _PropertyGet("ControlTipText") End Property ' ControlTipText (get) Property Let ControlTipText(ByVal pvValue As Variant) Call _PropertySet("ControlTipText", pvValue) End Property ' ControlTipText (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ControlType() As Variant ControlType = _PropertyGet("ControlType") End Property ' ControlType (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Default() As Variant Default = _PropertyGet("Default") End Property ' Default (get) Property Let Default(ByVal pvValue As Variant) Call _PropertySet("Default", pvValue) End Property ' Default (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get DefaultValue() As Variant DefaultValue = _PropertyGet("DefaultValue") End Property ' DefaultValue (get) Property Let DefaultValue(ByVal pvValue As Variant) Call _PropertySet("DefaultValue", pvValue) End Property ' DefaultValue (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Enabled() As Variant Enabled = _PropertyGet("Enabled") End Property ' Enabled (get) Property Let Enabled(ByVal pvValue As Variant) Call _PropertySet("Enabled", pvValue) End Property ' Enabled (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get FontBold() As Variant FontBold = _PropertyGet("FontBold") End Property ' FontBold (get) Property Let FontBold(ByVal pvValue As Variant) Call _PropertySet("FontBold", pvValue) End Property ' FontBold (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get FontItalic() As Variant FontItalic = _PropertyGet("FontItalic") End Property ' FontItalic (get) Property Let FontItalic(ByVal pvValue As Variant) Call _PropertySet("FontItalic", pvValue) End Property ' FontItalic (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get FontName() As Variant FontName = _PropertyGet("FontName") End Property ' FontName (get) Property Let FontName(ByVal pvValue As Variant) Call _PropertySet("FontName", pvValue) End Property ' FontName (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get FontSize() As Variant FontSize = _PropertyGet("FontSize") End Property ' FontSize (get) Property Let FontSize(ByVal pvValue As Variant) Call _PropertySet("FontSize", pvValue) End Property ' FontSize (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get FontUnderline() As Variant FontUnderline = _PropertyGet("FontUnderline") End Property ' FontUnderline (get) Property Let FontUnderline(ByVal pvValue As Variant) Call _PropertySet("FontUnderline", pvValue) End Property ' FontUnderline (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get FontWeight() As Variant FontWeight = _PropertyGet("FontWeight") End Property ' FontWeight (get) Property Let FontWeight(ByVal pvValue As Variant) Call _PropertySet("FontWeight", pvValue) End Property ' FontWeight (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ForeColor() As Variant ForeColor = _PropertyGet("ForeColor") End Property ' ForeColor (get) Property Let ForeColor(ByVal pvValue As Variant) Call _PropertySet("ForeColor", pvValue) End Property ' ForeColor (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Form() As Variant Form = _PropertyGet("Form") End Property ' Form (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Format() As Variant Format = _PropertyGet("Format") End Property ' Format (get) Property Let Format(ByVal pvValue As Variant) Call _PropertySet("Format", pvValue) End Property ' Format (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ItemData(ByVal Optional pvIndex As Variant) As Variant If IsMissing(pvIndex) Then ItemData = _PropertyGet("ItemData") Else ItemData = _PropertyGet("ItemData", pvIndex) End Property ' ItemData (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ListCount() As Variant ListCount = _PropertyGet("ListCount") End Property ' ListCount (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ListIndex() As Variant ListIndex = _PropertyGet("ListIndex") End Property ' ListIndex (get) Property Let ListIndex(ByVal pvValue As Variant) Call _PropertySet("ListIndex", pvValue) End Property ' ListIndex (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Locked() As Variant Locked = _PropertyGet("Locked") End Property ' Locked (get) Property Let Locked(ByVal pvValue As Variant) Call _PropertySet("Locked", pvValue) End Property ' Locked (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get MultiSelect() As Variant MultiSelect = _PropertyGet("MultiSelect") End Property ' MultiSelect (get) Property Let MultiSelect(ByVal pvValue As Variant) Call _PropertySet("MultiSelect", pvValue) End Property ' MultiSelect (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Name() As String Name = _PropertyGet("Name") End Property ' Name (get) Public Function pName() As String ' For compatibility with < V0.9.0 pName = _PropertyGet("Name") End Function ' pName (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ObjectType() As String ObjectType = _PropertyGet("ObjectType") End Property ' ObjectType (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnActionPerformed() As Variant OnActionPerformed = _PropertyGet("OnActionPerformed") End Property ' OnActionPerformed (get) Property Let OnActionPerformed(ByVal pvValue As Variant) Call _PropertySet("OnActionPerformed", pvValue) End Property ' OnActionPerformed (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnAdjustmentValueChanged() As Variant OnAdjustmentValueChanged = _PropertyGet("OnAdjustmentValueChanged") End Property ' OnAdjustmentValueChanged (get) Property Let OnAdjustmentValueChanged(ByVal pvValue As Variant) Call _PropertySet("OnAdjustmentValueChanged", pvValue) End Property ' OnAdjustmentValueChanged (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnApproveAction() As Variant OnApproveAction = _PropertyGet("OnApproveAction") End Property ' OnApproveAction (get) Property Let OnApproveAction(ByVal pvValue As Variant) Call _PropertySet("OnApproveAction", pvValue) End Property ' OnApproveAction (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnApproveReset() As Variant OnApproveReset = _PropertyGet("OnApproveReset") End Property ' OnApproveReset (get) Property Let OnApproveReset(ByVal pvValue As Variant) Call _PropertySet("OnApproveReset", pvValue) End Property ' OnApproveReset (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnApproveUpdate() As Variant OnApproveUpdate = _PropertyGet("OnApproveUpdate") End Property ' OnApproveUpdate (get) Property Let OnApproveUpdate(ByVal pvValue As Variant) Call _PropertySet("OnApproveUpdate", pvValue) End Property ' OnApproveUpdate (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnChanged() As Variant OnChanged = _PropertyGet("OnChanged") End Property ' OnChanged (get) Property Let OnChanged(ByVal pvValue As Variant) Call _PropertySet("OnChanged", pvValue) End Property ' OnChanged (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnErrorOccurred() As Variant OnErrorOccurred = _PropertyGet("OnErrorOccurred") End Property ' OnErrorOccurred (get) Property Let OnErrorOccurred(ByVal pvValue As Variant) Call _PropertySet("OnErrorOccurred", pvValue) End Property ' OnErrorOccurred (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnFocusGained() As Variant OnFocusGained = _PropertyGet("OnFocusGained") End Property ' OnFocusGained (get) Property Let OnFocusGained(ByVal pvValue As Variant) Call _PropertySet("OnFocusGained", pvValue) End Property ' OnFocusGained (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnFocusLost() As Variant OnFocusLost = _PropertyGet("OnFocusLost") End Property ' OnFocusLost (get) Property Let OnFocusLost(ByVal pvValue As Variant) Call _PropertySet("OnFocusLost", pvValue) End Property ' OnFocusLost (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnItemStateChanged() As Variant OnItemStateChanged = _PropertyGet("OnItemStateChanged") End Property ' OnItemStateChanged (get) Property Let OnItemStateChanged(ByVal pvValue As Variant) Call _PropertySet("OnItemStateChanged", pvValue) End Property ' OnItemStateChanged (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnKeyPressed() As Variant OnKeyPressed = _PropertyGet("OnKeyPressed") End Property ' OnKeyPressed (get) Property Let OnKeyPressed(ByVal pvValue As Variant) Call _PropertySet("OnKeyPressed", pvValue) End Property ' OnKeyPressed (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnKeyReleased() As Variant OnKeyReleased = _PropertyGet("OnKeyReleased") End Property ' OnKeyReleased (get) Property Let OnKeyReleased(ByVal pvValue As Variant) Call _PropertySet("OnKeyReleased", pvValue) End Property ' OnKeyReleased (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnMouseDragged() As Variant OnMouseDragged = _PropertyGet("OnMouseDragged") End Property ' OnMouseDragged (get) Property Let OnMouseDragged(ByVal pvValue As Variant) Call _PropertySet("OnMouseDragged", pvValue) End Property ' OnMouseDragged (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnMouseEntered() As Variant OnMouseEntered = _PropertyGet("OnMouseEntered") End Property ' OnMouseEntered (get) Property Let OnMouseEntered(ByVal pvValue As Variant) Call _PropertySet("OnMouseEntered", pvValue) End Property ' OnMouseEntered (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnMouseExited() As Variant OnMouseExited = _PropertyGet("OnMouseExited") End Property ' OnMouseExited (get) Property Let OnMouseExited(ByVal pvValue As Variant) Call _PropertySet("OnMouseExited", pvValue) End Property ' OnMouseExited (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnMouseMoved() As Variant OnMouseMoved = _PropertyGet("OnMouseMoved") End Property ' OnMouseMoved (get) Property Let OnMouseMoved(ByVal pvValue As Variant) Call _PropertySet("OnMouseMoved", pvValue) End Property ' OnMouseMoved (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnMousePressed() As Variant OnMousePressed = _PropertyGet("OnMousePressed") End Property ' OnMousePressed (get) Property Let OnMousePressed(ByVal pvValue As Variant) Call _PropertySet("OnMousePressed", pvValue) End Property ' OnMousePressed (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnMouseReleased() As Variant OnMouseReleased = _PropertyGet("OnMouseReleased") End Property ' OnMouseReleased (get) Property Let OnMouseReleased(ByVal pvValue As Variant) Call _PropertySet("OnMouseReleased", pvValue) End Property ' OnMouseReleased (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnResetted() As Variant OnResetted = _PropertyGet("OnResetted") End Property ' OnResetted (get) Property Let OnResetted(ByVal pvValue As Variant) Call _PropertySet("OnResetted", pvValue) End Property ' OnResetted (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnTextChanged() As Variant OnTextChanged = _PropertyGet("OnTextChanged") End Property ' OnTextChanged (get) Property Let OnTextChanged(ByVal pvValue As Variant) Call _PropertySet("OnTextChanged", pvValue) End Property ' OnTextChanged (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnUpdated() As Variant OnUpdated = _PropertyGet("OnUpdated") End Property ' OnUpdated (get) Property Let OnUpdated(ByVal pvValue As Variant) Call _PropertySet("OnUpdated", pvValue) End Property ' OnUpdated (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OptionValue() As Variant OptionValue = _PropertyGet("OptionValue") End Property ' OptionValue (get) Property Let OptionValue(ByVal pvValue As Variant) Call _PropertySet("OptionValue", pvValue) End Property ' OptionValue (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Page() As Variant Page = _PropertyGet("Page") End Property ' Page (get) Property Let Page(ByVal pvValue As Variant) Call _PropertySet("Page", pvValue) End Property ' Page (set) REM ----------------------------------------------------------------------------------------------------------------------- Public Function Parent() As Object Parent = _PropertyGet("Parent") End Function ' Parent (get) V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- Property Get Picture() As Variant Picture = _PropertyGet("Picture") End Property ' Picture (get) Property Let Picture(ByVal pvValue As Variant) Call _PropertySet("Picture", pvValue) End Property ' Picture (set) V1.5.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Properties(ByVal Optional pvIndex As Variant) As Variant ' Return ' a Collection object if pvIndex absent ' a Property object otherwise Utils._SetCalledSub("Control.Properties") Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String vPropertiesList = _PropertiesList() sObject = Utils._PCase(_Type) If IsMissing(pvIndex) Then vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) Else vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If Exit_Function: Set Properties = vProperty Utils._ResetCalledSub("Control.Properties") Exit Function End Function ' Properties REM ----------------------------------------------------------------------------------------------------------------------- Property Get Required() As Variant Required = _PropertyGet("Required") End Property ' Required (get) Property Let Required(ByVal pvValue As Variant) Call _PropertySet("Required", pvValue) End Property ' Required (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get RowSource() As Variant RowSource = _PropertyGet("RowSource") End Property ' RowSource (get) Property Let RowSource(ByVal pvValue As Variant) Call _PropertySet("RowSource", pvValue) End Property ' RowSource (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get RowSourceType() As Variant RowSourceType = _PropertyGet("RowSourceType") End Property ' RowSourceType (get) Property Let RowSourceType(ByVal pvValue As Variant) Call _PropertySet("RowSourceType", pvValue) End Property ' RowSourceType (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Selected(ByVal Optional pvIndex As Variant) As Variant If IsMissing(pvIndex) Then Selected = _PropertyGet("Selected") Else Selected = _PropertyGet("Selected", pvIndex) End Property ' Selected (get) Property Let Selected(ByVal pvValue As Variant) ' , ByVal Optional pvIndex As Variant) ' If IsMissing(pvIndex) Then Call _PropertySet("Selected", pvValue) Else Call _PropertySet("Selected", pvValue, pvIndex) Call _PropertySet("Selected", pvValue) End Property ' Selected (set) Public Function SelectedI(ByVal pvValue As variant, ByVal pvIndex As Variant) Call _PropertySet("Selected", pvValue, pvIndex) End Function REM ----------------------------------------------------------------------------------------------------------------------- Property Get SelLength() As Variant SelLength = _PropertyGet("SelLength") End Property ' SelLength (get) Property Let SelLength(ByVal pvValue As Variant) Call _PropertySet("SelLength", pvValue) End Property ' SelLength (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get SelStart() As Variant SelStart = _PropertyGet("SelStart") End Property ' SelStart (get) Property Let SelStart(ByVal pvValue As Variant) Call _PropertySet("SelStart", pvValue) End Property ' SelStart (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get SelText() As Variant SelText = _PropertyGet("SelText") End Property ' SelText (get) Property Let SelText(ByVal pvValue As Variant) Call _PropertySet("SelText", pvValue) End Property ' SelText (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get SpecialEffect() As Variant SpecialEffect = _PropertyGet("SpecialEffect") End Property ' SpecialEffect (get) Property Let SpecialEffect(ByVal pvValue As Variant) Call _PropertySet("SpecialEffect", pvValue) End Property ' SpecialEffect (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get SubType() As Variant SubType = _PropertyGet("SubType") End Property ' SubType (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get TabIndex() As Variant TabIndex = _PropertyGet("TabIndex") End Property ' TabIndex (get) Property Let TabIndex(ByVal pvValue As Variant) Call _PropertySet("TabIndex", pvValue) End Property ' TabIndex (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get TabStop() As Variant TabStop = _PropertyGet("TabStop") End Property ' TabStop (get) Property Let TabStop(ByVal pvValue As Variant) Call _PropertySet("TabStop", pvValue) End Property ' TabStop (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Tag() As Variant Tag = _PropertyGet("Tag") End Property ' Tag (get) Property Let Tag(ByVal pvValue As Variant) Call _PropertySet("Tag", pvValue) End Property ' Tag (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Text() As Variant Text = _PropertyGet("Text") End Property ' Text (get) Public Function pText() As variant pText = _PropertyGet("Text") End Function ' pText (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get TextAlign() As Variant TextAlign = _PropertyGet("TextAlign") End Property ' TextAlign (get) Property Let TextAlign(ByVal pvValue As Variant) Call _PropertySet("TextAlign", pvValue) End Property ' TextAlign (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get TripleState() As Variant TripleState = _PropertyGet("TripleState") End Property ' TripleState (get) Property Let TripleState(ByVal pvValue As Variant) Call _PropertySet("TripleState", pvValue) End Property ' TripleState (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Value() As Variant Value = _PropertyGet("Value") End Property ' Value (get) Property Let Value(ByVal pvValue As Variant) Call _PropertySet("Value", pvValue) End Property ' Value (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Visible() As Variant Visible = _PropertyGet("Visible") End Property ' Visible (get) Property Let Visible(ByVal pvValue As Variant) Call _PropertySet("Visible", pvValue) End Property ' Visible (set) REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- Public Function AddItem(ByVal Optional pvItem As Variant, ByVal Optional pvIndex) As Boolean ' Add an item in a Listbox Utils._SetCalledSub("Control.AddItem") AddItem = False If _ErrorHandler() Then On Local Error Goto Error_Function If IsMissing(pvItem) Then Call _TraceArguments() If IsMissing(pvIndex) Then pvIndex = -1 Dim iArgNr As Integer Select Case UCase(_A2B_.CalledSub) Case UCase("AddItem") : iArgNr = 1 Case UCase("Control.AddItem") : iArgNr = 0 End Select If Not Utils._CheckArgument(pvItem, iArgNr + 1, vbString) Then Goto Exit_Function If Not Utils._CheckArgument(pvIndex, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function If _SubType <> CTLLISTBOX Then Goto Error_Control If _ParentType <> CTLPARENTISDIALOG Then If ControlModel.ListSourceType <> com.sun.star.form.ListSourceType.VALUELIST Then Goto Error_Control End If Dim vRowSource() As Variant, iCount As Integer, i As Integer If IsArray(ControlModel.StringItemList) Then vRowSource = ControlModel.StringItemList Else vRowSource = Array(ControlModel.StringItemList) iCount = UBound(vRowSource) If pvIndex < -1 Or pvIndex > iCount + 1 Then Goto Error_Index ReDim Preserve vRowSource(0 To iCount + 1) If pvIndex = -1 Then pvIndex = iCount + 1 For i = iCount + 1 To pvIndex + 1 Step -1 vRowSource(i) = vRowSource(i - 1) Next i vRowSource(pvIndex) = pvItem If _ParentType <> CTLPARENTISDIALOG Then ControlModel.ListSource = vRowSource() End If ControlModel.StringItemList = vRowSource() AddItem = True Exit_Function: Utils._ResetCalledSub("Control.AddItem") Exit Function Error_Function: TraceError(TRACEABORT, Err, "Control.AddItem", Erl) AddItem = False GoTo Exit_Function Error_Control: TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , "Control.AddItem") AddItem = False Goto Exit_Function Error_Index: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(iArgNr + 2,pvIndex)) AddItem = False Goto Exit_Function End Function ' AddItem V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Controls(Optional ByVal pvIndex As Variant) As Variant ' Return a Control object with name or index = pvIndex Const cstThisSub = "Control.Controls" If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub(cstThisSub) Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String Dim j As Integer, oView As Object If _SubType <> CTLGRIDCONTROL Then Goto Trace_Error_Context Set ocControl = Nothing iControlCount = ControlModel.getCount() If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object Set oCounter = New Collect Set oCounter._This = oCounter oCounter._CollType = COLLCONTROLS Set oCounter._Parent = _This oCounter._Count = iControlCount Set Controls = oCounter Goto Exit_Function End If If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function ' Start building the ocControl object ' Determine exact name Set ocControl = New Control Set ocControl._This = ocControl Set ocControl._Parent = _This ocControl._ParentType = CTLPARENTISGRID sParentShortcut = _Shortcut sControls() = ControlModel.getElementNames() Select Case VarType(pvIndex) Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index ocControl._Name = sControls(pvIndex) Case vbString ' Check control name validity (non case sensitive) bFound = False sIndex = UCase(Utils._Trim(pvIndex)) For i = 0 To iControlCount - 1 If UCase(sControls(i)) = sIndex Then bFound = True Exit For End If Next i If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound End Select With ocControl ._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name) Set .ControlModel = ControlModel.getByName(._Name) ._ImplementationName = .ControlModel.ColumnServiceName ' getImplementationName aborts for subcontrols !? ._FormComponent = ParentComponent ._MainForm = _MainForm If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId ' Complex bypass to find View of grid subcontrols ! If Not IsNull(ControlView) Then ' Anticipate absence of ControlView in grid controls when edit mode For i = 0 to ControlView.getCount() - 1 Set oView = ControlView.GetByIndex(i) If Not IsNull(oView) Then If oView.getModel.Name = ._Name Then Set .ControlView = oView Exit For End If End If Next i End If ._Initialize() ._DocEntry = _DocEntry ._DbEntry = _DbEntry End With Set Controls = ocControl Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Error_Index: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) Set Controls = Nothing Goto Exit_Function Trace_NotFound: TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name)) Set Controls = Nothing Goto Exit_Function Trace_Error_Context: TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , "Grid.Controls") Set Controls = Nothing Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) Set Controls = Nothing GoTo Exit_Function End Function ' Controls REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant, ByVal Optional pvIndex As Variant) As Variant ' Return property value of psProperty property name Utils._SetCalledSub("Control.getProperty") If IsMissing(pvProperty) Then Call _TraceArguments() If IsMissing(pvIndex) Then getProperty = _PropertyGet(pvProperty) Else getProperty = _PropertyGet(pvProperty, pvIndex) End If Utils._ResetCalledSub("Control.getProperty") End Function ' getProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean ' Return True if object has a valid property called pvProperty (case-insensitive comparison !) If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) Exit Function End Function ' hasProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function RemoveItem(ByVal Optional pvIndex) As Boolean ' Remove an item from a Listbox ' Index may be a string value or an index-position Utils._SetCalledSub("Control.RemoveItem") If _ErrorHandler() Then On Local Error Goto Error_Function If IsMissing(pvIndex) Then Call _TraceArguments() Dim iArgNr As Integer Select Case UCase(_A2B_.CalledSub) Case UCase("RemoveItem") : iArgNr = 1 Case UCase("Control.RemoveItem") : iArgNr = 0 End Select If Not Utils._CheckArgument(pvIndex, iArgNr + 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function If _SubType <> CTLLISTBOX Then Goto Error_Control If _ParentType <> CTLPARENTISDIALOG Then If ControlModel.ListSourceType <> com.sun.star.form.ListSourceType.VALUELIST Then Goto Error_Control End If Dim vRowSource() As Variant, iCount As Integer, i As Integer, j As integer, bFound As Boolean If IsArray(ControlModel.StringItemList) Then vRowSource = ControlModel.StringItemList Else vRowSource = Array(ControlModel.StringItemList) iCount = UBound(vRowSource) Select Case VarType(pvIndex) Case vbString bFound = False For i = 0 To iCount If vRowSource(i) = pvIndex Then For j = i To iCount - 1 vRowSource(j) = vRowSource(j + 1) Next j bFound = True Exit For ' Remove only 1st occurrence of string End If Next i Case Else If pvIndex < 0 Or pvIndex > iCount Then Goto Error_Index For i = pvIndex To iCount - 1 vRowSource(i) = vRowSource(i + 1) Next i bFound = True End Select If bFound Then If iCount > 0 Then ' https://forum.openoffice.org/en/forum/viewtopic.php?f=47&t=75008 ReDim Preserve vRowSource(0 To iCount - 1) Else vRowSource = Array() End If If _ParentType <> CTLPARENTISDIALOG Then ControlModel.ListSource = vRowSource() End If ControlModel.StringItemList = vRowSource() RemoveItem = True Else RemoveItem = False End If Exit_Function: Utils._ResetCalledSub("Control.RemoveItem") Exit Function Error_Function: TraceError(TRACEABORT, Err, "Control.RemoveItem", Erl) RemoveItem = False GoTo Exit_Function Error_Control: TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.RemoveItem") RemoveItem = False Goto Exit_Function Error_Index: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(2, pvIndex)) RemoveItem = False Goto Exit_Function End Function ' RemoveItem V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Requery() As Boolean ' Refresh data displayed in a form, subform, combobox or listbox Utils._SetCalledSub("Control.Requery") If _ErrorHandler() Then On Local Error Goto Error_Function Requery = False Select Case _SubType Case CTLCOMBOBOX, CTLLISTBOX If Utils._InList(ControlModel.ListSourceType, Array( _ com.sun.star.form.ListSourceType.QUERY _ , com.sun.star.form.ListSourceType.TABLE _ , com.sun.star.form.ListSourceType.TABLEFIELDS _ , com.sun.star.form.ListSourceType.SQL _ , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ )) Then ControlModel.refresh() End If Case Else Goto Error_Control End Select Requery = True Exit_Function: Utils._ResetCalledSub("Control.Requery") Exit Function Error_Control: TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.Requery") Requery = False Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "Control.Requery", Erl) GoTo Exit_Function End Function ' Requery REM ----------------------------------------------------------------------------------------------------------------------- Public Function SetFocus() As Boolean ' Execute setFocus method Utils._SetCalledSub("Control.SetFocus") If _ErrorHandler() Then On Local Error Goto Error_Function SetFocus = False Dim i As Integer, j As Integer, iColPosition As Integer Dim ocControl As Object, ocGrid As Variant, oGridModel As Object If IsNull(ControlView) Then GoTo Exit_Function If _ParentType = CTLPARENTISGRID Then 'setFocus method does not work on controlviews in grid ?!? ' Find column position of control iColPosition = -1 ocGrid = getObject(_getUpperShortcut(_Shortcut, _Name)) ' return containing grid Set oGridModel = ocGrid.ControlModel j = -1 For i = 0 To oGridModel.Count - 1 Set ocControl = oGridModel.GetByIndex(i) If Not ocControl.Hidden Then j = j + 1 ' Skip if hidden If oGridModel.GetByIndex(i).Name = _Name Then iColPosition = j Exit For End If Next i If iColPosition >= 0 Then ocGrid.ControlView.setFocus() 'Set first focus on grid itself ocGrid.ControlView.setCurrentColumnPosition(iColPosition) 'Deprecated but no alternative found Else Goto Error_Grid End If Else ControlView.setFocus() End If SetFocus = True Exit_Function: Utils._ResetCalledSub("Control.SetFocus") Exit Function Error_Function: TraceError(TRACEABORT, Err, "Control.SetFocus", Erl) Goto Exit_Function Error_Grid: TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(_Name, ocGrid._Name)) Goto Exit_Function End Function ' SetFocus V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean ' Return True if property setting OK Utils._SetCalledSub("Control.setProperty") If IsMissing(pvIndex) Then setProperty = _PropertySet(psProperty, pvValue) Else setProperty = _PropertySet(psProperty, pvValue, pvIndex) End If Utils._ResetCalledSub("Control.setProperty") End Function ' setProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function SetSelected(ByVal Optional pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean ' Workaround for limitation of Basic: Property Let does not accept optional arguments If IsMissing(pvValue) Then Call _TraceArguments() If IsMissing(pvIndex) Then SetSelected = _PropertySet("Selected", pvValue) Else SetSelected = _PropertySet("Selected", pvValue, pvIndex) End If End Function ' SetSelected REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Function _Formats(ByVal psControlType As String) As Variant ' Return allowed format entries for Date and Time control types Dim vFormats() As Variant Select Case psControlType Case CTLDATEFIELD vFormats = Array( _ "Standard (short)" _ , "Standard (short YY)" _ , "Standard (short YYYY)" _ , "Standard (long)" _ , "DD/MM/YY" _ , "MM/DD/YY" _ , "YY/MM/DD" _ , "DD/MM/YYYY" _ , "MM/DD/YYYY" _ , "YYYY/MM/DD" _ , "YY-MM-DD" _ , "YYYY-MM-DD" _ ) Case CTLTIMEFIELD vFormats = Array( _ "24h short" _ , "24h long" _ , "12h short" _ , "12h long" _ ) Case Else vFormats = Array() End Select _Formats = vFormats End Function ' _Formats V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _GetListener(ByVal psProperty As String) As String ' Return the X...Listener corresponding with the property in argument Select Case UCase(psProperty) Case UCase("OnActionPerformed") _GetListener = "XActionListener" Case UCase("OnAdjustmentValueChanged") _GetListener = "XAdjustmentListener" Case UCase("OnApproveAction") _GetListener = "XApproveActionListener" Case UCase("OnApproveReset"), UCase("OnResetted") _GetListener = "XResetListener" Case UCase("OnApproveUpdate"), UCase("OnUpdated") _GetListener = "XUpdateListener" Case UCase("OnChanged") _GetListener = "XChangeListener" Case UCase("OnErrorOccurred") _GetListener = "XErrorListener" 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" End Select End Function ' _GetListener V1.7.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _Initialize() ' Initialize new Control ' ControlModel, ParentType, Name, Shortcut, ControlView, ImplementationName, ClassId (if parent <> dialog) ' are presumed preexisting ' Identify SubType and ControlView Dim sControlTypes() As Variant, i As Integer, vSplit() As Variant, sTrailer As String sControlTypes = array( CTLCONTROL _ , CTLCOMMANDBUTTON _ , CTLRADIOBUTTON _ , CTLIMAGEBUTTON _ , CTLCHECKBOX _ , CTLLISTBOX _ , CTLCOMBOBOX _ , CTLGROUPBOX _ , CTLTEXTFIELD _ , CTLFIXEDTEXT _ , CTLGRIDCONTROL _ , CTLFILECONTROL _ , CTLHIDDENCONTROL _ , CTLIMAGECONTROL _ , CTLDATEFIELD _ , CTLTIMEFIELD _ , CTLNUMERICFIELD _ , CTLCURRENCYFIELD _ , CTLPATTERNFIELD _ , CTLSCROLLBAR _ , CTLSPINBUTTON _ , CTLNAVIGATIONBAR _ , CTLPROGRESSBAR _ , CTLFIXEDLINE _ ) Select Case _ParentType Case CTLPARENTISDIALOG vSplit = Split(ControlModel.getServiceName(), ".") sTrailer = UCase(vSplit(UBound(vSplit))) ' Manage homonyms Select Case sTrailer Case "BUTTON" : sTrailer = CTLCOMMANDBUTTON Case "EDIT" : sTrailer = CTLTEXTFIELD Case Else End Select If sTrailer <> CTLFORMATTEDFIELD Then For i = 0 To UBound(sControlTypes) If sControlTypes(i) = sTrailer Then _ClassId = i + 1 _SubType = sTrailer _ControlType = _ClassId Exit For End If Next i Else _ClassId = acFormattedField _SubType = CTLFORMATTEDFIELD _ControlType = _ClassId End If Case Else 'Is ClassId one of the properties ? If _ClassId > 0 Then ' All control types have a ClassId except subforms _SubType = sControlTypes(_ClassId - 1) _ControlType = _ClassId If _SubType = CTLTEXTFIELD Then ' Formatted fields belong to the TextField family If _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper" _ Or _ImplementationName = "com.sun.star.comp.forms.OFormattedFieldWrapper_ForcedFormatted" _ Or _ImplementationName = "com.sun.star.form.component.FormattedField" Then ' When in datagrid _SubType = CTLFORMATTEDFIELD _ControlType = acFormattedField End If End If Else ' Initialize subform Control If ControlModel.ImplementationName = "com.sun.star.comp.forms.ODatabaseForm" Then _SubType = CTLSUBFORM _ControlType = acSubform End If End If End Select End Sub ' _Initialize REM ----------------------------------------------------------------------------------------------------------------------- Public Function _ListboxBound() As Boolean ' Return True if listbox has a bound column Dim bListboxBound As Boolean, j As Integer Dim vValue() As variant, vString As Variant bListboxBound = False If Not IsNull(ControlModel.ValueItemList) _ And ControlModel.DataField <> "" _ And Not IsNull(ControlModel.BoundField) _ And Utils._InList(ControlModel.ListSourceType, Array( _ com.sun.star.form.ListSourceType.TABLE _ , com.sun.star.form.ListSourceType.QUERY _ , com.sun.star.form.ListSourceType.SQL _ , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ )) Then ' MultiSelect behaviour changed in OpenOffice >= 3.3 If IsArray(ControlModel.ValueItemList) Then vValue = ControlModel.ValueItemList vString = ControlModel.StringItemList For j = 0 To UBound(vValue) If VarType(vValue(j)) <> VarType(vString(j)) Then bListboxBound = True ElseIf vValue(j) <> vString(j) Then bListboxBound = True End If If bListboxBound Then Exit For Next j End If End If _ListboxBound = bListboxBound End Function ' _ListboxBound V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant ' Based on ControlProperties.ods analysis Dim vFullPropertiesList() As Variant 'List established only once If UBound(_ThisProperties) > -1 Then _PropertiesList = _ThisProperties Exit Function End If vFullPropertiesList = Array( _ "BackColor" _ , "BorderColor" _ , "BorderStyle" _ , "Cancel" _ , "Caption" _ , "ControlSource" _ , "ControlTipText" _ , "ControlType" _ , "Default" _ , "DefaultValue" _ , "Enabled" _ , "FontBold" _ , "FontItalic" _ , "FontName" _ , "FontSize" _ , "FontUnderline" _ , "FontWeight" _ , "ForeColor" _ , "Form" _ , "Format" _ , "ItemData" _ , "LinkChildFields" _ , "LinkMasterFields" _ , "ListCount" _ , "ListIndex" _ , "Locked" _ , "MultiSelect" _ , "Name" _ , "ObjectType" _ , "OnActionPerformed" _ , "OnAdjustmentValueChanged" _ , "OnApproveAction" _ , "OnApproveReset" _ , "OnApproveUpdate" _ , "OnChanged" _ , "OnErrorOccurred" _ , "OnFocusGained" _ , "OnFocusLost" _ , "OnItemStateChanged" _ , "OnKeyPressed" _ , "OnKeyReleased" _ , "OnMouseDragged" _ , "OnMouseEntered" _ , "OnMouseExited" _ , "OnMouseMoved" _ , "OnMousePressed" _ , "OnMouseReleased" _ , "OnResetted" _ , "OnTextChanged" _ , "OnUpdated" _ , "OptionValue" _ , "Page" _ , "Parent" _ , "Picture" _ , "Required" _ , "RowSource" _ , "RowSourceType" _ , "Selected" _ , "SelLength" _ , "SelStart" _ , "Seltext" _ , "SpecialEffect" _ , "SubType" _ , "TabIndex" _ , "TabStop" _ , "Tag" _ , "Text" _ , "TextAlign" _ , "TripleState" _ , "Value" _ , "Visible" _ ) Dim vPropertiesMatrix(25) As Variant Select Case _ParentType Case CTLPARENTISFORM, CTLPARENTISSUBFORM vPropertiesMatrix(acCheckBox) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,52,54,61,62,63,64,65,67,68,69,70) vPropertiesMatrix(acComboBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,27,28,29,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,52,54,55,56,62,63,64,65,66,67,69,70) vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,29,31,32,36,37,38,39,40,41,42,43,44,45,46,47,52,53,62,63,64,65,67,69,70) vPropertiesMatrix(acCurrencyField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,67,69,70) vPropertiesMatrix(acDateField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70) vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,36,37,39,40,41,42,43,44,45,46,47,48,52,62,63,64,65,66,69,70) vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,52,62,65,67,70) vPropertiesMatrix(acFormattedField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70) vPropertiesMatrix(acGridControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,70) vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,32,36,37,39,40,41,42,43,44,45,46,47,52,62,65,70) vPropertiesMatrix(acHiddenControl) = Array(7,27,28,52,62,65,69,70) vPropertiesMatrix(acImageButton) = Array(0,1,2,6,7,10,27,28,31,36,37,39,40,41,42,43,44,45,46,52,53,62,63,64,65,70) vPropertiesMatrix(acImageControl) = Array(0,1,2,5,6,7,10,25,27,28,32,36,37,39,40,41,42,43,44,45,46,47,52,53,54,62,63,64,65,70) vPropertiesMatrix(acListBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,29,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,49,52,54,55,56,57,62,63,64,65,67,69,70) vPropertiesMatrix(acNavigationBar) = Array(0,2,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,52,62,63,64,65,70) vPropertiesMatrix(acNumericField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,67,69,70) vPropertiesMatrix(acPatternField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,63,64,65,66,67,69,70) vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,50,52,54,61,62,63,64,65,67,69,70) vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,32,33,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,69,70) vPropertiesMatrix(acSpinButton) = Array(0,1,2,6,7,9,10,27,28,30,32,33,36,37,39,40,41,42,43,44,45,46,47,49,52,62,63,64,65,69,70) vPropertiesMatrix(0) = Array(7,18,21,22,27,28,52,62) vPropertiesMatrix(acTextField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,32,33,34,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,63,64,65,66,67,69,70) vPropertiesMatrix(acTimeField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,63,64,65,66,67,69,70) Case CTLPARENTISGROUP ' To be duplicated from above !!! vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,50,52,54,61,62,63,64,65,67,69,70) Case CTLPARENTISGRID vPropertiesMatrix(acCheckBox) = Array(4,5,6,7,9,10,27,28,29,32,36,37,38,39,40,41,42,43,44,45,46,47,52,54,61,62,65,67,68,69) vPropertiesMatrix(acComboBox) = Array(4,5,6,7,9,10,20,23,24,25,27,28,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,52,54,55,56,62,65,66,67,69) vPropertiesMatrix(acCurrencyField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,67,69) vPropertiesMatrix(acDateField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69) vPropertiesMatrix(acFormattedField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,35,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69) vPropertiesMatrix(acListBox) = Array(4,5,6,7,9,10,20,23,24,25,26,27,28,32,33,35,36,37,38,39,40,41,42,43,44,45,46,47,49,52,54,55,56,57,62,65,67,69) vPropertiesMatrix(acNumericField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,67,69) vPropertiesMatrix(acPatternField) = Array(4,5,6,7,9,10,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,65,66,67,69) vPropertiesMatrix(acTextField) = Array(4,5,6,7,9,10,25,27,28,32,33,34,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,58,59,60,62,65,66,67,69) vPropertiesMatrix(acTimeField) = Array(4,5,6,7,9,10,19,25,27,28,32,33,36,37,39,40,41,42,43,44,45,46,47,48,49,52,54,62,65,66,67,69) Case CTLPARENTISDIALOG vPropertiesMatrix(acCheckBox) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,61,62,63,64,65,67,68,69,70) vPropertiesMatrix(acComboBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,27,28,29,36,37,38,39,40,41,42,43,44,45,46,48,51,52,55,62,63,64,65,66,67,69,70) vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,53,62,63,64,65,67,70) vPropertiesMatrix(acCurrencyField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,67,69,70) vPropertiesMatrix(acDateField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) vPropertiesMatrix(acFixedLine) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,70) vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,64,65,67,70) vPropertiesMatrix(acFormattedField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,70) vPropertiesMatrix(acImageControl) = Array(0,1,2,6,7,10,27,28,36,37,39,40,41,42,43,44,45,46,51,52,53,62,63,64,65,70) vPropertiesMatrix(acListBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,29,36,37,38,39,40,41,42,43,44,45,46,51,52,55,57,62,63,64,65,67,69,70) vPropertiesMatrix(acNavigationBar) = Array(36,37,39,40,41,42,43,44,45,46) vPropertiesMatrix(acNumericField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,67,69,70) vPropertiesMatrix(acPatternField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,58,59,60,62,63,64,65,66,67,69,70) vPropertiesMatrix(acProgressBar) = Array(0,1,2,6,7,10,27,28,36,37,39,40,41,42,43,44,45,46,51,52,62,63,65,69,70) vPropertiesMatrix(acRadioButton) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,36,37,38,39,40,41,42,43,44,45,46,50,51,52,61,62,63,64,65,67,69,70) vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,36,37,39,40,41,42,43,44,45,46,51,52,62,63,64,65,69,70) vPropertiesMatrix(acTextField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,58,59,60,62,63,64,65,66,67,69,70) vPropertiesMatrix(acTimeField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,36,37,39,40,41,42,43,44,45,46,48,51,52,62,63,64,65,66,67,69,70) End Select Dim i As Integer, iIndex As Integer If _ControlType = acSubForm Then iIndex = 0 Else iIndex = _ControlType If IsEmpty(vPropertiesMatrix(iIndex)) Then _ThisProperties = Array() Else ReDim _ThisProperties(0 To UBound(vPropertiesMatrix(iIndex))) For i = 0 To UBound(_ThisProperties) _ThisProperties(i) = vFullPropertiesList(vPropertiesMatrix(iIndex)(i)) Next i End If _PropertiesList = _ThisProperties() End Function ' _PropertiesList REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant ' Return property value of the psProperty property name Dim iArg As Integer If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Control.get" & psProperty) _PropertyGet = EMPTY 'Check Index argument Dim iArgNr As Integer If Not IsMissing(pvIndex) Then Select Case UCase(_A2B_.CalledSub) Case UCase("getProperty") : iArgNr = 3 Case UCase("Control.getProperty") : iArgNr = 2 Case UCase("Control.get" & psProperty) : iArgNr = 1 End Select If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function End If Dim vDefaultValue As Variant, oDefaultValue As Object, vValue As Variant, oValue As Object, iIndex As Integer Dim lListIndex As Long, i As Integer, j As Integer, vCurrentValue As Variant, lListCount As Long Dim vListboxValue As Variant, vListSource, bSelected() As Boolean, bListboxBound As Boolean Dim vGet As Variant, vDate As Variant Dim ofSubForm As Object Dim vFormats() As Variant Dim vSelection As Variant, sSelectedText As String Dim oControlEvents As Object, sEventName As String If Not hasProperty(psProperty) Then Goto Trace_Error Select Case UCase(psProperty) Case UCase("BackColor") If Utils._hasUNOProperty(ControlModel, "BackgroundColor") Then _PropertyGet = ControlModel.BackgroundColor Case UCase("BorderColor") If Utils._hasUNOProperty(ControlModel, "BorderColor") Then _PropertyGet = ControlModel.BorderColor Case UCase("BorderStyle") If Utils._hasUNOProperty(ControlModel, "Border") Then _PropertyGet = ControlModel.Border Case UCase("Cancel") If Utils._hasUNOProperty(ControlModel, "PushButtonType") Then _PropertyGet = ( ControlModel.PushButtonType = com.sun.star.awt.PushButtonType.CANCEL ) Case UCase("Caption") If Utils._hasUNOProperty(ControlModel, "Label") Then _PropertyGet = ControlModel.Label Case UCase("ControlSource") If Utils._hasUNOProperty(ControlModel, "DataField") Then _PropertyGet = ControlModel.DataField Case UCase("ControlTipText") If Utils._hasUNOProperty(ControlModel, "HelpText") Then _PropertyGet = ControlModel.HelpText Case UCase("ControlType") _PropertyGet = _ControlType Case UCase("Default") If Utils._hasUNOProperty(ControlModel, "DefaultButton") Then _PropertyGet = ControlModel.DefaultButton Case UCase("DefaultValue") Select Case _SubType Case CTLCHECKBOX, CTLRADIOBUTTON If Utils._hasUNOProperty(ControlModel, "DefaultState") Then _PropertyGet = ControlModel.DefaultState Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD If Utils._hasUNOProperty(ControlModel, "DefaultText") Then _PropertyGet = ControlModel.DefaultText Case CTLCURRENCYFIELD, CTLNUMERICFIELD If Utils._hasUNOProperty(ControlModel, "DefaultValue") Then _PropertyGet = ControlModel.DefaultValue Case CTLDATEFIELD If Utils._hasUNOProperty(ControlModel, "DefaultDate") Then Select Case VarType(ControlModel.DefaultDate) Case vbLong ' AOO and LO <= 4.1 vDefaultValue = ControlModel.DefaultDate vGet = DateSerial(Left(vDefaultValue, 4), Mid(vDefaultValue, 5, 2), Right(vDefaultValue, 2)) Case vbObject ' LO >= 4.2 com.sun.star.Util.Date Set oDefaultValue = ControlModel.DefaultDate vGet = DateSerial(oDefaultValue.Year,oDefaultValue.Month, oDefaultValue.Day) Case vbEmpty End Select End If Case CTLFORMATTEDFIELD If Utils._hasUNOProperty(ControlModel, "EffectiveDefault") Then _PropertyGet = ControlModel.EffectiveDefault Case CTLLISTBOX If Utils._hasUNOProperty(ControlModel, "DefaultSelection") And Utils._hasUNOProperty(ControlModel, "StringItemList") Then vDefaultValue = ControlModel.DefaultSelection If IsArray(vDefaultValue) Then If UBound(vDefaultValue) >= LBound(vDefaultValue) Then ' Is array initialized ? iIndex = UBound(ControlModel.StringItemList) If vDefaultValue(0) >= 0 And vDefaultValue(0) <= iIndex Then _PropertyGet = ControlModel.StringItemList(vDefaultValue(0)) ' Only first default value is considered End If End If End If Case CTLSPINBUTTON If Utils._hasUNOProperty(ControlModel, "DefaultSpinValue") Then _PropertyGet = ControlModel.DefaultSpinValue Case CTLTIMEFIELD If Utils._hasUNOProperty(ControlModel, "DefaultTime") Then Select Case VarType(ControlModel.DefaultTime) Case vbLong ' AOO and LO <= 4.1 _PropertyGet = ControlModel.DefaultTime Case vbObject ' LO >= 4.2 com.sun.star.Util.Time Set oDefaultValue = ControlModel.DefaultTime _PropertyGet = TimeSerial(oDefaultValue.Hours, oDefaultValue.Minutes, oDefaultValue.Seconds) Case vbEmpty End Select End If Case Else Goto Trace_Error End Select Case UCase("Enabled") If Utils._hasUNOProperty(ControlModel, "Enabled") Then _PropertyGet = ControlModel.Enabled Case UCase("FontBold") If Utils._hasUNOProperty(ControlModel, "FontWeight") Then _PropertyGet = ( ControlModel.FontWeight >= com.sun.star.awt.FontWeight.BOLD ) Case UCase("FontItalic") If Utils._hasUNOProperty(ControlModel, "FontSlant") Then _PropertyGet = ( ControlModel.FontSlant = com.sun.star.awt.FontSlant.ITALIC ) Case UCase("FontName") If Utils._hasUNOProperty(ControlModel, "FontName") Then _PropertyGet = ControlModel.FontName Case UCase("FontSize") If Utils._hasUNOProperty(ControlModel, "FontHeight") Then _PropertyGet = ControlModel.FontHeight Case UCase("FontUnderline") If Utils._hasUNOProperty(ControlModel, "FontUnderline") Then _PropertyGet = _ Not ( ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.NONE _ Or ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.DONTKNOW ) Case UCase("FontWeight") If Utils._hasUNOProperty(ControlModel, "FontWeight") Then _PropertyGet = ControlModel.FontWeight Case UCase("ForeColor") If Utils._hasUNOProperty(ControlModel, "TextColor") Then _PropertyGet = ControlModel.TextColor Case UCase("Form") Set ofSubForm = New SubForm ' Start building the SUBFORM object With ofSubForm Set ._This = ofSubForm Set .DatabaseForm = ControlModel ._Name = _Name ._Shortcut = _Shortcut & ".Form" ._MainForm = _MainForm .ParentComponent = _FormComponent ._DocEntry = _DocEntry ._DbEntry = _DbEntry ._OrderBy = ControlModel.Order End With set _PropertyGet = ofSubForm Case UCase("Format") vFormats = _Formats(_Subtype) Select Case _SubType Case CTLDATEFIELD If Utils._hasUNOProperty(ControlModel, "DateFormat") Then If ControlModel.DateFormat <= UBound(vFormats) Then _PropertyGet = vFormats(ControlModel.DateFormat) End If Case CTLTIMEFIELD If Utils._hasUNOProperty(ControlModel, "TimeFormat") Then If ControlModel.TimeFormat <= UBound(vFormats) Then _PropertyGet = vFormats(ControlModel.TimeFormat) End If Case Else If Utils._hasUNOProperty(ControlModel, "FormatKey") Then If Utils._hasUNOProperty(ControlModel, "FormatsSupplier") Then _PropertyGet = ControlModel.FormatsSupplier.getNumberFormats.getByKey(ControlModel.FormatKey).FormatString End If End If End Select Case UCase("ItemData") If Utils._hasUNOProperty(ControlModel, "StringItemList") Then If IsMissing(pvIndex) Then _PropertyGet = ControlModel.StringItemList Else If pvIndex < 0 Or pvIndex > UBound(ControlModel.StringItemList) Then Goto Trace_Error_Index _PropertyGet = ControlModel.StringItemList(pvIndex) End If End If Case UCase("ListCount") If Utils._hasUNOProperty(ControlModel, "StringItemList") Then _PropertyGet = UBound(ControlModel.StringItemList) + 1 Case UCase("ListIndex") If Utils._hasUNOProperty(ControlModel, "StringItemList") Then lListIndex = -1 ' Either Multiple selections or no selection at all Select Case _SubType Case CTLCOMBOBOX If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto Trace_Error iIndex = 0 If ControlModel.Text <> "" Then For j = 0 To UBound(ControlModel.StringItemList) If ControlModel.StringItemList(j) = ControlModel.Text Then lListIndex = j iIndex = iIndex + 1 End If Next j If iIndex <> 1 Then lListIndex = -1 ' Multiselection or synonyms rejected End If Case CTLLISTBOX ' No mean found to access bound column !! See mail Lionel 10/5/2013 for improvement If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error If UBound(ControlModel.SelectedItems) > 0 Then ' Several items selected Else ' Mono selection If _ParentType <> CTLPARENTISDIALOG Then ' getCurrentValue not found in dialog listboxes ?? vCurrentValue = ControlModel.getCurrentValue() ' Space or uninitialized array if no selection at all If IsArray(vCurrentValue) Then ' Is an array if MultiSelect vListboxValue = "" If UBound(vCurrentValue) = 0 Then vListboxValue = vCurrentValue(0) Else vListboxValue = vCurrentValue End If If vListboxValue <> "" Then ' Speed up search PM Pastim 12/02/2013 If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) End If Else If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) End If End If End Select _PropertyGet = lListIndex End If Case UCase("Locked") If Utils._hasUNOProperty(ControlModel, "ReadOnly") Then _PropertyGet = ControlModel.ReadOnly Case UCase("MultiSelect") If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then _PropertyGet = ControlModel.MultiSelection ' Boolean in OO, Integer (0, 1 or 2) in VBA ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then ' Not documented: only for GridControls !? Changed in OO >= 3,3 !? _PropertyGet = ControlModel.MultiSelectionSimpleMode Else _PropertyGet = False End If Case UCase("Name") _PropertyGet = _Name Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset") _ , UCase("OnApproveUpdate"), UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained") _ , UCase("OnFocusLost"), UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted"), UCase("OnTextChanged") _ , UCase("OnUpdated") Select Case _ParentType Case CTLPARENTISDIALOG Set oControlEvents = ControlModel.getEvents() sEventName = "com.sun.star.awt." & _GetListener(psProperty) & "::" & Utils._GetEventName(psProperty) If oControlEvents.hasByName(sEventName) Then _PropertyGet = oControlEvents.getByName(sEventName).ScriptCode Else _PropertyGet = "" End If Case Else _PropertyGet = Utils._GetEventScriptCode(ControlModel, psProperty, _Name) End Select Case UCase("OptionValue") If Utils._hasUNOProperty(ControlModel, "RefValue") Then If ControlModel.RefValue <> "" Then _PropertyGet = ControlModel.RefValue ElseIf Utils._hasUNOProperty(ControlModel, "Label") Then _PropertyGet = ControlModel.Label End If End If Case UCase("ObjectType") _PropertyGet = _Type Case UCase("Page") If Utils._hasUNOProperty(ControlModel, "Step") Then _PropertyGet = ControlModel.Step Case UCase("Parent") Set _PropertyGet = _Parent Case UCase("Picture") _PropertyGet = ConvertToUrl(ControlModel.ImageURL) Case UCase("Required") If Utils._hasUNOProperty(ControlModel, "InputRequired") Then _PropertyGet = ControlModel.InputRequired Case UCase("RowSource") Select Case _ParentType Case CTLPARENTISDIALOG If Utils._hasUNOProperty(ControlModel, "StringItemList") Then If IsArray(ControlModel.StringItemList) Then vListSource = ControlModel.StringItemList Else vListSource = Array(ControlModel.StringItemList) _PropertyGet = Join(vListSource, ";") End If Case Else If Utils._hasUNOProperty(ControlModel, "ListSource") Then Select Case ControlModel.ListSourceType Case com.sun.star.form.ListSourceType.VALUELIST _ , com.sun.star.form.ListSourceType.TABLEFIELDS If IsArray(ControlModel.StringItemList) Then vListSource = ControlModel.StringItemList Else vListSource = Array(ControlModel.StringItemList) Case com.sun.star.form.ListSourceType.TABLE _ , com.sun.star.form.ListSourceType.QUERY _ , com.sun.star.form.ListSourceType.SQL _ , com.sun.star.form.ListSourceType.SQLPASSTHROUGH If IsArray(ControlModel.ListSource) Then vListSource = ControlModel.ListSource Else vListSource = Array(ControlModel.ListSource) End Select _PropertyGet = Join(vListSource, ";") End If End Select Case UCase("RowSourceType") If Utils._hasUNOProperty(ControlModel, "ListSourceType") Then _PropertyGet = ControlModel.ListSourceType Case UCase("Selected") If Utils._hasUNOProperty(ControlModel, "StringItemList") Then lListIndex = UBound(ControlModel.StringItemList) If Not IsMissing(pvIndex) Then If pvIndex < 0 Or pvIndex > lListIndex Then Goto Trace_Error_Index End If If lListIndex < 0 Then ' Do nothing if listbox empty _PropertyGet = Array() Else Redim bSelected(0 To lListIndex) For j = 0 To lListIndex bSelected(j) = False Next j For j = 0 To UBound(ControlModel.SelectedItems) iIndex = ControlModel.SelectedItems(j) If iIndex >= 0 And iIndex <= lListIndex Then bSelected(iIndex) = True Next j If IsMissing(pvIndex) Then _PropertyGet = bSelected Else _PropertyGet = bSelected(pvIndex) End If End If Case UCase("SelLength") If Utils._hasUNOProperty(ControlView, "Selection") Then vSelection = ControlView.getSelection() If vSelection.Max >= vSelection.Min Then _PropertyGet = vSelection.Max - vSelection.Min Else _PropertyGet = 0 ' probably control does not have focus End If Else _PropertyGet = 0 End If Case UCase("SelStart") If Utils._hasUNOProperty(ControlView, "Selection") Then vSelection = ControlView.getSelection() If vSelection.Max >= vSelection.Min Then _PropertyGet = vSelection.Min + 1 Else _PropertyGet = 1 ' probably control does not have focus End If Else _PropertyGet = 1 End If Case UCase("SelText") If Utils._hasUNOProperty(ControlView, "SelectedText") Then _PropertyGet = ControlView.getSelectedText() Else _PropertyGet = "" End If Case UCase("SpecialEffect") If Utils._hasUNOProperty(ControlModel, "VisualEffect") Then _PropertyGet = ControlModel.VisualEffect Case UCase("SubType") _PropertyGet = _SubType Case UCase("TabIndex") If Utils._hasUNOProperty(ControlModel, "TabIndex") Then _PropertyGet = ControlModel.TabIndex Case UCase("TabStop") If Utils._hasUNOProperty(ControlModel, "Tabstop") Then _PropertyGet = ControlModel.Tabstop Case UCase("Tag") If Utils._hasUNOProperty(ControlModel, "Tag") Then _PropertyGet = ControlModel.Tag Case UCase("Text") Select Case _SubType Case CTLDATEFIELD If Utils._hasUNOProperty(ControlModel, "Date") Then If Utils._hasUNOProperty(ControlModel, "FormatKey") Then If Utils._hasUNOProperty(ControlModel, "FormatsSupplier") Then Select Case VarType(ControlModel.Date) Case vbLong ' AOO and LO <= 4.1 vDate = DateSerial(Left(ControlModel.Date, 4), Mid(ControlModel.Date, 5, 2), Right(ControlModel.Date, 2)) Case vbObject ' LO >= 4.2 vDate = DateSerial(ControlModel.Date.Year, ControlModel.Date.Month, ControlModel.Date.Day) Case vbEmpty End Select _PropertyGet = Format(vDate, ControlModel.FormatsSupplier.getNumberFormats.getByKey(ControlModel.FormatKey).FormatString) End If End If End If Case CTLTIMEFIELD If Utils._hasUNOProperty(ControlModel, "Text") Then Select Case VarType(ControlModel.Time) Case vbLong ' AOO and LO <= 4.1 _PropertyGet = Format(ControlModel.Time, "HH:MM:SS") Case vbObject ' LO >= 4.2 com.sun.star.Util.Time Set oValue = ControlModel.Time _PropertyGet = Format(TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds), "HH:MM:SS") Case vbEmpty End Select End If Case Else If Utils._hasUNOProperty(ControlModel, "Text") Then _PropertyGet = ControlModel.Text End Select Case UCase("TextAlign") If Utils._hasUNOProperty(ControlModel, "Tag") Then _PropertyGet = ControlModel.Tag Case UCase("TripleState") If Utils._hasUNOProperty(ControlModel, "TriState") Then _PropertyGet = ControlModel.TriState Case UCase("Value") Select Case _SubType Case CTLCHECKBOX If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ControlModel.State Case CTLCOMMANDBUTTON vGet = False If Utils._hasUNOProperty(ControlModel, "Toggle") Then If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ( ControlModel.State = 1 ) End If Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD If Utils._hasUNOProperty(ControlModel, "Text") Then vGet = ControlModel.Text Case CTLCURRENCYFIELD If Utils._hasUNOProperty(ControlModel, "Value") Then vGet = ControlModel.Value Case CTLDATEFIELD If Utils._hasUNOProperty(ControlModel, "Date") Then Select Case VarType(ControlModel.Date) Case vbLong ' AOO and LO <= 4.1 vValue = ControlModel.Date vGet = DateSerial(Left(vValue, 4), Mid(vValue, 5, 2), Right(vValue, 2)) Case vbObject ' LO >= 4.2 com.sun.star.Util.Date Set oValue = ControlModel.Date vGet = DateSerial(oValue.Year, oValue.Month, oValue.Day) Case vbEmpty End Select End If Case CTLFORMATTEDFIELD If Utils._hasUNOProperty(ControlModel, "EffectiveValue") Then vGet = ControlModel.EffectiveValue Case CTLHIDDENCONTROL If Utils._hasUNOProperty(ControlModel, "HiddenValue") Then vGet = ControlModel.HiddenValue Case CTLLISTBOX If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error If UBound(ControlModel.SelectedItems) > 0 Then ' Several items selected vGet = EMPTY ' Listbox has no value, only an array of Selected flags to identify values Else ' Mono selection Select Case _ParentType Case CTLPARENTISDIALOG If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) If lListIndex > -1 And lListIndex <= UBound(ControlModel.StringItemList) Then vGet = ControlModel.StringItemList(lListIndex) Else vGet = EMPTY End If End If Case Else 'getCurrentValue does not return any significant value anymore ' Speed up getting value PM PASTIM 12/02/2013 If Ubound(ControlModel.SelectedItems) >= 0 Then lListIndex = Controlmodel.Selecteditems(0) Else lListIndex = -1 ' If listbox has hidden column = real bound field, then explore ValueItemList If _ListboxBound() Then If lListIndex > -1 Then vGet = ControlModel.ValueItemList(lListIndex) ' PASTIM Else If lListIndex > -1 Then vGet = ControlModel.getItemText(lListIndex) End If End Select End If Case CTLNUMERICFIELD If Utils._hasUNOProperty(ControlModel, "Value") Then vGet = ControlModel.Value Case CTLPROGRESSBAR If Utils._hasUNOProperty(ControlModel, "ProgressValue") Then vGet = ControlModel.ProgressValue Case CTLSCROLLBAR If Utils._hasUNOProperty(ControlModel, "ScrollValue") Then vGet = ControlModel.ScrollValue Case CTLSPINBUTTON If Utils._hasUNOProperty(ControlModel, "SpinValue") Then vGet = ControlModel.SpinValue Case CTLTIMEFIELD If Utils._hasUNOProperty(ControlModel, "Time") Then Select Case VarType(ControlModel.Time) Case vbLong ' AOO and LO <= 4.1 vGet = ControlModel.Time Case vbObject ' LO >= 4.2 com.sun.star.Util.Time Set oValue = ControlModel.Time vGet = TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds) Case vbEmpty End Select End If Case Else End Select If _SubType <> CTLLISTBOX Then ' Give getCurrentValue an additional try If IsEmpty(vGet) And Utils._hasUNOMethod(ControlModel, "getCurrentValue") Then vGet = ControlModel.getCurrentValue() End If _PropertyGet = vGet Case UCase("Visible") Select Case _SubType Case CTLHIDDENCONTROL _PropertyGet = False Case Else If Utils._hasUNOMethod(ControlView, "isVisible") Then _PropertyGet = CBool(ControlView.isVisible()) End Select Case Else Goto Trace_Error End Select If IsEmpty(_PropertyGet) Then TraceError(TRACEINFO, ERRPROPERTYINIT, Utils._CalledSub(), 0, , psProperty) Exit_Function: Utils._ResetCalledSub("Control.get" & psProperty) Exit Function Trace_Error: TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) _PropertyGet = EMPTY Goto Exit_Function Trace_Error_Index: TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) _PropertyGet = EMPTY Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "Control._PropertyGet", Erl) _PropertyGet = EMPTY GoTo Exit_Function End Function ' _PropertyGet V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant, ByVal Optional pvIndex As Variant) As Boolean ' Return True if property setting OK If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Control.set" & psProperty) _PropertySet = True 'Check Index argument If Not IsMissing(pvIndex) Then If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric()) Then Goto Exit_Function End If 'Execute Dim iArgNr As Integer, vButton As Variant, i As Integer Dim odbDatabase As Object, vNames() As Variant, bFound As Boolean, sName As String Dim bMultiSelect As Boolean, iCount As Integer, iSelectedItems() As Integer, lListCount As Long, bSelected() As Boolean Dim vItemList() As Variant, vFormats() As Variant Dim oStruct As Object, sValue As String Dim vSelection As Variant, sText As String, lStart As long Dim oControlEvents As Object, sListener As String, sEvent As String, sEventName As String, oEvent As Object _PropertySet = True Select Case UCase(_A2B_.CalledSub) Case UCase("setProperty") : iArgNr = 3 Case UCase("Control.setProperty") : iArgNr = 2 Case UCase("Control.set" & psProperty) : iArgNr = 1 End Select If Not hasProperty(psProperty) Then Goto Trace_Error Select Case UCase(psProperty) Case UCase("BackColor") If Not Utils._hasUNOProperty(ControlModel, "BackgroundColor") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value ControlModel.BackgroundColor = CLng(pvValue) Case UCase("BorderColor") If Not Utils._hasUNOProperty(ControlModel, "BorderColor") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value ControlModel.BorderColor = CLng(pvValue) Case UCase("BorderStyle") If Not Utils._hasUNOProperty(ControlModel, "BorderColor") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = No border, 1 = 3D border, 2 = Normal border ControlModel.Border = CLng(pvValue) Case UCase("Cancel") If Not Utils._hasUNOProperty(ControlModel, "PushButtonType") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If pvValue Then vButton = com.sun.star.awt.PushButtonType.CANCEL Else vButton = com.sun.star.awt.PushButtonType.STANDARD ControlModel.PushButtonType = vButton Case UCase("Caption") If Not Utils._hasUNOProperty(ControlModel, "Label") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value ControlModel.Label = pvValue Case UCase("ControlTipText") If Not Utils._hasUNOProperty(ControlModel, "HelpText") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value ControlModel.HelpText = pvValue Case UCase("Default") If Not Utils._hasUNOProperty(ControlModel, "DefaultButton") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value ControlModel.DefaultButton = pvValue Case UCase("DefaultValue") Select Case _SubType Case CTLDATEFIELD If Not Utils._hasUNOProperty(ControlModel, "DefaultDate") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value Select Case VarType(ControlModel.DefaultDate) Case vbEmpty, vbLong ' AOO and LO <= 4.1 ControlModel.DefaultDate = Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue) Case vbObject ' LO >= 4.2 com.sun.star.Util.Date ControlModel.DefaultDate.Year = Year(pvValue) ControlModel.DefaultDate.Month = Month(pvValue) ControlModel.DefaultDate.Day = Day(pvValue) End Select Case CTLLISTBOX If Not Utils._hasUNOProperty(ControlModel, "DefaultSelection") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value For i = 0 To UBound(ControlModel.StringItemList) If UCase(pvValue) = UCase(ControlModel.StringItemList(i)) Then ControlModel.DefaultSelection = Array(i) Exit For End If Next i Case CTLSPINBUTTON If Not Utils._hasUNOProperty(ControlModel, "DefaultSpinValue") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value ControlModel.DefaultSpinValue = pvValue Case CTLCHECKBOX If Not Utils._hasUNOProperty(ControlModel, "DefaultState") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know ControlModel.DefaultState = pvValue Case CTLRADIOBUTTON If Not Utils._hasUNOProperty(ControlModel, "DefaultState") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 0 Or pvValue > 1 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked ControlModel.DefaultState = pvValue Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD If Not Utils._hasUNOProperty(ControlModel, "DefaultText") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value ControlModel.DefaultText = pvValue Case CTLTIMEFIELD If Not Utils._hasUNOProperty(ControlModel, "DefaultTime") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue >= 0 And pvValue <= 23595999 Then Select Case VarType(ControlModel.DefaultTime) Case vbEmpty, vbLong ' AOO and LO <= 4.1 ControlModel.DefaultTime = pvValue Case vbObject ' LO >= 4.2 com.sun.star.Util.Time ControlModel.DefaultDate.Hours = Hour(pvValue) ControlModel.DefaultDate.Minutes = Minute(pvValue) ControlModel.DefaultDate.Seconds = Second(pvValue) End Select Else Goto Trace_Error_Value End If Case CTLCURRENCYFIELD, CTLNUMERICFIELD If Not Utils._hasUNOProperty(ControlModel, "DefaultValue") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value ControlModel.DefaultValue = pvValue Case CTLFORMATTEDFIELD If Not Utils._hasUNOProperty(ControlModel, "EffectiveDefault") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value ControlModel.EffectiveDefault = pvValue ' Thanks, PASTIM Case Else Goto Trace_Error End Select Case UCase("Enabled") If Not Utils._hasUNOProperty(ControlModel, "Enabled") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value ControlModel.Enabled = pvValue Case UCase("FontBold") If Not Utils._hasUNOProperty(ControlModel, "FontWeight") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If pvValue Then ' Iif construction does not work ! ControlModel.FontWeight = com.sun.star.awt.FontWeight.BOLD Else ControlModel.FontWeight = com.sun.star.awt.FontWeight.NORMAL End If Case UCase("FontItalic") If Not Utils._hasUNOProperty(ControlModel, "FontSlant") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If pvValue Then ' Iif construction does not work ! ControlModel.FontSlant = com.sun.star.awt.FontSlant.ITALIC Else ControlModel.FontSlant = com.sun.star.awt.FontSlant.NONE End If Case UCase("FontName") If Not Utils._hasUNOProperty(ControlModel, "FontName") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value ControlModel.FontName = pvValue Case UCase("FontSize") If Not Utils._hasUNOProperty(ControlModel, "FontHeight") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 1 Or pvValue > 127 Then Goto Trace_Error_Value ControlModel.FontHeight = pvValue Case UCase("FontUnderline") If Not Utils._hasUNOProperty(ControlModel, "FontUnderline") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If pvValue Then ' Iif construction does not work ! ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.SINGLE Else ControlModel.FontUnderline = com.sun.star.awt.FontUnderline.NONE End If Case UCase("FontWeight") If Not Utils._hasUNOProperty(ControlModel, "FontWeight") Then Goto Trace_Error If Not Utils._IsScalar(CSng(pvValue), vbSingle, Array( _ com.sun.star.awt.FontWeight.THIN _ , com.sun.star.awt.FontWeight.ULTRALIGHT _ , com.sun.star.awt.FontWeight.LIGHT _ , com.sun.star.awt.FontWeight.SEMILIGHT _ , com.sun.star.awt.FontWeight.NORMAL _ , com.sun.star.awt.FontWeight.SEMIBOLD _ , com.sun.star.awt.FontWeight.BOLD _ , com.sun.star.awt.FontWeight.ULTRABOLD _ , com.sun.star.awt.FontWeight.BLACK _ )) Then Goto Trace_Error_Value ControlModel.FontWeight = pvValue Case UCase("Format") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value vFormats = _Formats(_SubType) Select Case _SubType Case CTLDATEFIELD, CTLTIMEFIELD bFound = False For i = 0 To UBound(vFormats) If UCase(pvValue) = UCase(vFormats(i)) Then If _SubType = CTLDATEFIELD Then If Utils._hasUNOProperty(ControlModel, "DateFormat") Then ControlModel.DateFormat = i Else Goto Trace_Error Else If Utils._hasUNOProperty(ControlModel, "TimeFormat") Then ControlModel.TimeFormat = i Else Goto Trace_Error End If bFound = True Exit For End If Next i If Not bFound Then Goto Trace_Error_Value Case Else Goto Trace_Error End Select Case UCase("ForeColor") If Not Utils._hasUNOProperty(ControlModel, "TextColor") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value ControlModel.TextColor = CLng(pvValue) Case UCase("ListIndex") If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 0 Or pvValue > UBound(ControlModel.StringItemList) Then Goto Trace_Error_Value Select Case _SubType Case CTLCOMBOBOX ControlModel.Text = ControlModel.StringItemList(pvValue) Case CTLLISTBOX ControlModel.SelectedItems = Array(pvValue) End Select Case UCase("Locked") If Not Utils._hasUNOProperty(ControlModel, "ReadOnly") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value ControlModel.ReadOnly = pvValue Case UCase("MultiSelect") If Not Utils._hasUNOProperty(ControlModel, "MultiSelection") And Not Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then ControlModel.MultiSelection = pvValue ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then ControlModel.MultiSelectionSimpleMode = pvValue End If If Not pvValue Then ControlModel.SelectedItems = Array() ' Cancel selections when MultiSelect becomes False Case UCase("OnActionPerformed"), UCase("OnAdjustmentValueChanged"), UCase("OnApproveAction"), UCase("OnApproveReset") _ , UCase("OnApproveUpdate"), UCase("OnChanged"), UCase("OnErrorOccurred"), UCase("OnFocusGained") _ , UCase("OnFocusLost"), UCase("OnItemStateChanged"), UCase("OnKeyPressed"), UCase("OnKeyReleased") _ , UCase("OnMouseDragged"), UCase("OnMouseEntered"), UCase("OnMouseExited"), UCase("OnMouseMoved") _ , UCase("OnMousePressed"), UCase("OnMouseReleased"), UCase("OnResetted"), UCase("OnTextChanged") _ , UCase("OnUpdated") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value Select Case _ParentType Case CTLPARENTISDIALOG If Not Utils._RegisterDialogEventScript(ControlModel _ , psProperty _ , _GetListener(psProperty) _ , pvValue _ ) Then GoTo Trace_Error Case Else If Not Utils._RegisterEventScript(ControlModel _ , psProperty _ , _GetListener(psProperty) _ , pvValue _ , _Name _ ) Then GoTo Trace_Error End Select Case UCase("OptionValue") If Not Utils._hasUNOProperty(ControlModel, "RefValue") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value If Not Utils._hasUNOProperty(ControlModel, "Label") Then If pvValue = "" Then Goto Trace_Error_Value If ControlModel.RefValue <> "" Then ControlModel.RefValue = pvValue Else ControlModel.Label = pvValue End If Case UCase("Page") If Not Utils._hasUNOProperty(ControlModel, "Step") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 0 Then Goto Trace_Error_Value ControlModel.Step = pvValue Case UCase("Picture") If Not Utils._hasUNOProperty(ControlModel, "ImageURL") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value ControlModel.ImageURL = ConvertToUrl(pvValue) Case UCase("Required") If Not Utils._hasUNOProperty(ControlModel, "InputRequired") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value ControlModel.InputRequired = pvValue Case UCase("RowSource") Select Case _ParentType Case CTLPARENTISDIALOG If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error ControlModel.StringItemList = Split(pvValue, ";") Case Else If Not Utils._hasUNOProperty(ControlModel, "ListSource") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value Select Case ControlModel.ListSourceType Case com.sun.star.form.ListSourceType.QUERY _ , com.sun.star.form.ListSourceType.TABLE _ , com.sun.star.form.ListSourceType.TABLEFIELDS Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry) If ControlModel.ListSourceType = com.sun.star.form.ListSourceType.QUERY Then vNames = odbDatabase.Connection.getQueries.GetElementNames _ Else vNames = odbDatabase.Connection.getTables.GetElementNames bFound = False ' Check existence of table or query and find its correct (case-sensitive) name For i = 0 To UBound(vNames) If UCase(vNames(i)) = UCase(pvValue) Then bFound = True sName = vNames(i) Exit For End If Next i If Not bFound Then Goto Trace_Error_Value If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = sName Else ControlModel.ListSource = Array(sName) ControlModel.refresh() Case com.sun.star.form.ListSourceType.SQL Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry) If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = odbDatabase._ReplaceSquareBrackets(pvValue) Else ControlModel.ListSource = Array(odbDatabase._ReplaceSquareBrackets(pvValue)) ControlModel.refresh() Case com.sun.star.form.ListSourceType.VALUELIST ' Forbidden for COMBOBOX ! If _SubType = CTLCOMBOBOX Then Goto Trace_Error ControlModel.ListSource = Split(pvValue, ";") ControlModel.StringItemList = ControlModel.ListSource Case com.sun.star.form.ListSourceType.SQLPASSTHROUGH If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = pvValue Else ControlModel.ListSource = Array(pvValue) ControlModel.refresh() End Select End Select If _SubType = CTLLISTBOX Then ControlModel.SelectedItems = Array() Case UCase("RowSourceType") ' Refresh done when RowSource changes, not RowSourceType If Not Utils._hasUNOProperty(ControlModel, "ListSourceType") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If Not Utils._IsScalar(pvValue, Utils._AddNumeric(), Array( _ com.sun.star.form.ListSourceType.VALUELIST _ , com.sun.star.form.ListSourceType.TABLE _ , com.sun.star.form.ListSourceType.QUERY _ , com.sun.star.form.ListSourceType.SQL _ , com.sun.star.form.ListSourceType.SQLPASSTHROUGH _ , com.sun.star.form.ListSourceType.TABLEFIELDS _ )) Then Goto Trace_Error_Value ControlModel.ListSourceType = pvValue Case UCase("Selected") If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Then Goto Trace_Error If Not Utils._hasUNOProperty(ControlModel, "StringItemList") Then Goto Trace_Error If Utils._hasUNOProperty(ControlModel, "MultiSelection") Then bMultiSelect = ControlModel.MultiSelection ElseIf Utils._hasUNOProperty(ControlModel, "MultiSelectionSimpleMode") Then bMultiSelect = ControlModel.MultiSelectionSimpleMode Else: Goto Trace_Error End If lListCount = UBound(ControlModel.StringItemList) + 1 If IsMissing(pvIndex) Then ' Full boolean array passed If Not IsArray(pvValue) Then Goto Trace_Error_Array If LBound(pvValue) <> 0 Or UBound(pvValue) < 0 Then Goto Trace_Error_Array If Not Utils._CheckArgument(pvValue(0), iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If UBound(pvValue) <> lListCount - 1 Then Goto Trace_Error_Index iCount = 0 For i = 0 To UBound(pvValue) ' Count True values If pvValue(i) Then iCount = iCount + 1 Next i If iCount > 0 Then Redim iSelectedItems(0 To iCount - 1) iCount = 0 For i = 0 To UBound(pvValue) If pvValue(i) Then iSelectedItems(iCount) = i iCount = iCount + 1 End If Next i ControlModel.SelectedItems = iSelectedItems ' iSelectedItems maps OO internals (size = # of selected items) Else ControlModel.SelectedItems = Array() End If Else ' Single boolean value passed If Not Utils._CheckArgument(pvIndex, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function If pvIndex < 0 Or pvIndex >= lListCount Then Goto Trace_Error_Index If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value ReDim bSelected(0 To lListCount - 1) ' bSelected maps VBA internals (size = # of displayed items) If Not bMultiSelect Then ' Set all other values to False For i = 0 To lListCount - 1 If i = pvIndex Then bSelected(i) = pvValue ' All entries = False except one Else bSelected(i) = False End If Next i Else For i = 0 To lListCount - 1 bSelected(i) = False Next i iSelectedItems = ControlModel.SelectedItems iCount = UBound(iSelectedItems) For i = 0 To iCount bSelected(iSelectedItems(i)) = True Next i bSelected(pvIndex) = pvValue End If iCount = 0 ' Rebuild SelectedItems For i = 0 To lListCount - 1 If bSelected(i) Then iCount = iCount + 1 Next i If iCount > 0 Then Redim iSelectedItems(0 To iCount - 1) iCount = 0 For i = 0 To lListCount - 1 If bSelected(i) Then iSelectedItems(iCount) = i iCount = iCount + 1 End If Next i ControlModel.SelectedItems = iSelectedItems Else ControlModel.SelectedItems = Array() End If End If Case UCase("SelLength") If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 0 Then Goto Trace_Error_Value vSelection = ControlView.getSelection() vSelection.Max = vSelection.Min + pvValue ControlView.setSelection(vSelection) Case UCase("SelStart") If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 1 Or pvValue > Len(ControlModel.Text) + 1 Then Goto Trace_Error_Value vSelection = ControlView.getSelection() vSelection.Min = pvValue - 1 vSelection.Max = pvValue - 1 ' Also reset length to 0 ControlView.setSelection(vSelection) Case UCase("SelText") If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value If Len(pvValue) > 0 Then vSelection = ControlView.getSelection() sText = ControlModel.Text lStart = InStr(1, sText, pvValue, 0) ' Case sensitive ! If lStart > 0 Then vSelection.Min = lStart - 1 vSelection.Max = lStart + Len(pvValue) - 1 ControlView.setSelection(vSelection) End If End If Case UCase("SpecialEffect") If Not Utils._hasUNOProperty(ControlModel, "VisualEffect") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = None, 1 = Look3D, 2 = Flat ControlModel.VisualEffect = pvValue Case UCase("TabIndex") If Not Utils._hasUNOProperty(ControlModel, "TabIndex") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < -1 Then Goto Trace_Error_Value ControlModel.TabIndex = pvValue Case UCase("TabStop") If Not Utils._hasUNOProperty(ControlModel, "Tabstop") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value ControlModel.Tabstop = pvValue Case UCase("Tag") If Not Utils._hasUNOProperty(ControlModel, "Tag") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value ControlModel.Tag = pvValue Case UCase("TextAlign") If Not Utils._hasUNOProperty(ControlModel, "Align") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Left, 1 = Center, 2 = Right ControlModel.Align = pvValue Case UCase("TripleState") If Not Utils._hasUNOProperty(ControlModel, "TriState") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value ControlModel.TriState = pvValue Case UCase("Value") Select Case _SubType Case CTLCHECKBOX If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbBoolean), , False) Then Goto Trace_Error_Value If VarType(pvValue) = vbBoolean Then pvValue = Iif(pvValue, 1, 0) If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know ControlModel.State = pvValue Case CTLCOMMANDBUTTON If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error If Not Utils._hasUNOProperty(ControlModel, "Toggle") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If pvValue Then ControlModel.State = 1 Else ControlModel.State = 0 Case CTLCOMBOBOX If Not Utils._hasUNOProperty(ControlModel, "Text") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _ Then Goto Trace_Error If pvValue <> "" Then If Not Utils._CheckArgument(pvValue, iArgNr, vbString, ControlModel.StringItemList, False) Then Goto Trace_Error_Value End If ControlModel.Text = pvValue Case CTLCURRENCYFIELD, CTLNUMERICFIELD If Not Utils._hasUNOProperty(ControlModel, "Value") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value ControlModel.Value = pvValue Case CTLDATEFIELD If Not Utils._hasUNOProperty(ControlModel, "Date") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value Select Case _InspectPropertyType(ControlModel, "Date") Case "long" ' AOO and LO <= 4.1 'ControlModel.Date = Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue) ' Gives error in dialogs ?!? ControlModel.setPropertyValue("Date", Year(pvValue) * 10000 + Month(pvValue) * 100 + Day(pvValue)) Case "com.sun.star.util.Date" ' LO >= 4.2 'Direct assignment of ControlModel.Date.Xxx has no effect ?!? Set oStruct = CreateUnoStruct("com.sun.star.util.Date") oStruct.Year = Year(pvValue) oStruct.Month = Month(pvValue) oStruct.Day = Day(pvValue) Set ControlModel.Date = oStruct End Select Case CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value ControlModel.Text = pvValue Case CTLFORMATTEDFIELD If Not Utils._hasUNOProperty(ControlModel, "EffectiveValue") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbString), , False) Then Goto Trace_Error_Value ControlModel.EffectiveValue = pvValue Case CTLHIDDENCONTROL If Not Utils._hasUNOProperty(ControlModel, "HiddenValue") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(Array(vbString, vbBoolean, vbDate)), , False) Then Goto Trace_Error_Value ControlModel.HiddenValue = pvValue Case CTLLISTBOX If Not Utils._hasUNOProperty(ControlModel, "SelectedItems") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _ Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(Array(vbString, vbDate)), , False) Then Goto Trace_Error_Value ' PASTIM If IsArray(pvValue) Then Goto Trace_Error_Value ' Setting the value on a listbox is allowed only if single value and value in the list ' Check ValueItemList bFound = False Select Case _ParentType Case CTLPARENTISDIALOG vItemList = ControlModel.StringItemList Case Else If _ListboxBound() Then ' Performance improvement (PASTIM PM 9 Feb 2013) If Not Utils._hasUNOProperty(ControlModel, "ValueItemList") Then Goto Trace_Error vItemList = ControlModel.ValueItemList Else vItemList = ControlModel.StringItemList End If End Select For i = 0 To UBound(vItemList) If pvValue = vItemList(i) Then bFound = True Exit For End If Next i If bFound Then ControlModel.SelectedItems = Array(i) Else Goto Trace_Error_Value Case CTLPROGRESSBAR If Not Utils._hasUNOProperty(ControlModel, "ProgressValue") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If Utils._hasUNOProperty(ControlModel, "ProgressValueMin") Then If pvValue < ControlModel.ProgressValueMin Then Goto Trace_Error_Value End If If Utils._hasUNOProperty(ControlModel, "ProgressValueMax") Then If pvValue > ControlModel.ProgressValueMax Then Goto Trace_Error_Value End If ControlModel.ProgressValue = pvValue Case CTLSCROLLBAR If Not Utils._hasUNOProperty(ControlModel, "ScrollValue") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If Utils._hasUNOProperty(ControlModel, "ScrollValueMin") Then If pvValue < ControlModel.ScrollValueMin Then Goto Trace_Error_Value End If If Utils._hasUNOProperty(ControlModel, "ScrollValueMax") Then If pvValue > ControlModel.ScrollValueMax Then Goto Trace_Error_Value End If ControlModel.ScrollValue = pvValue Case CTLSPINBUTTON If Not Utils._hasUNOProperty(ControlModel, "SpinValue") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If Utils._hasUNOProperty(ControlModel, "SpinValueMin") Then If pvValue < ControlModel.SpinValueMin Then Goto Trace_Error_Value End If If Utils._hasUNOProperty(ControlModel, "SpinValueMax") Then If pvValue > ControlModel.SpinValueMax Then Goto Trace_Error_Value End If ControlModel.SpinValue = pvValue Case CTLTIMEFIELD If Not Utils._hasUNOProperty(ControlModel, "Time") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value Select Case _InspectPropertyType(ControlModel, "Time") Case "long" ' AOO and LO <= 4.0 ControlModel.Time = CLng(pvValue) Case "com.sun.star.util.Time" ' LO >= 4.1 'Direct assignment of ControlModel.Time.Xxx gives error ?!? Set oStruct = CreateUnoStruct("com.sun.star.util.Time") sValue = Right("00000000" & Str(CLng(pvValue)), 8) oStruct.Hours = Val(Left(sValue, 2)) oStruct.Minutes = Val(Mid(sValue, 3, 2)) oStruct.Seconds = Val(Mid(sValue, 5, 2)) Set ControlModel.Time = oStruct End Select Case Else Goto Trace_Error End Select ' FINAL COMMITMENT If Utils._hasUNOMethod(ControlModel, "commit") Then ControlModel.commit() ' f.i. checkboxes have no commit method ?? [PASTIM] Case UCase("Visible") If _SubType = CTLHIDDENCONTROL Then Goto Trace_Error ' Hidden remains hidden !! If Not Utils._hasUNOMethod(ControlView, "setVisible") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If pvValue Then ControlModel.EnableVisible = True ControlView.setVisible(pvValue) Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub("Control.set" & psProperty) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) _PropertySet = False Goto Exit_Function Trace_Error_Value: TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) _PropertySet = False Goto Exit_Function Trace_Error_Index: TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) _PropertySet = False Goto Exit_Function Trace_Error_Array: TraceError(TRACEFATAL, ERRPROPERTYNOTARRAY, Utils._CalledSub(), 0, 1, iArgNr) _PropertySet = False Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "Control._PropertySet", Erl) _PropertySet = False GoTo Exit_Function End Function ' _PropertySet V1.1.0