EVOLUTION-MANAGER
Edit File: OptionGroup.xba
<?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> <script:module xmlns:script="http://openoffice.org/2000/script" script:name="OptionGroup" script:language="StarBasic">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 FORM Private _Name As String Private _ParentType As String Private _ParentComponent As Object Private _DocEntry As Integer Private _DbEntry As Integer Private _ButtonsGroup() As Variant Private _ButtonsIndex() As Variant Private _Count As Long REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJOPTIONGROUP _Name = "" _ParentType = "" _ParentComponent = Nothing _DocEntry = -1 _DbEntry = -1 _ButtonsGroup = Array() _ButtonsIndex = Array() _Count = 0 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 Count() As Variant Count = _PropertyGet("Count") End Property ' Count (get) 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 ----------------------------------------------------------------------------------------------------------------------- Public Function Properties(ByVal Optional pvIndex As Variant) As Variant ' Return ' a Collection object if pvIndex absent ' a Property object otherwise Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String vPropertiesList = _PropertiesList() sObject = Utils._PCase(_Type) If IsMissing(pvIndex) Then vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList) Else vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If Exit_Function: Set Properties = vProperty Exit Function End Function ' Properties 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 ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- Public Function Controls(Optional ByVal pvIndex As Variant) As Variant ' Return a Control object with name or index = pvIndex If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("OptionGroup.Controls") Dim ocControl As Variant, iArgNr As Integer, i As Integer Set ocControl = Nothing If IsMissing(pvIndex) Then ' No argument, return Collection object Set oCounter = New Collect oCounter._SubType = OBJCONTROL oCounter._ParentType = OBJOPTIONGROUP oCounter._ParentName = _Name oCounter._Count = _Count Set Controls = oCounter Goto Exit_Function End If If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2 If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function If pvIndex < 0 Or pvIndex > _Count - 1 Then Goto Trace_Error_Index ' Start building the ocControl object ' Determine exact name Set ocControl = New Control ocControl._ParentType = CTLPARENTISGROUP ocControl._Shortcut = "" For i = 0 To _Count - 1 If _ButtonsIndex(i) = pvIndex Then Set ocControl.ControlModel = _ButtonsGroup(i) Select Case _ParentType Case CTLPARENTISDIALOG : ocControl._Name = _ButtonsGroup(i).Name Case Else : ocControl._Name = _Name ' OptionGroup and individual radio buttons share the same name End Select ocControl._ImplementationName = ocControl.ControlModel.getImplementationName() Exit For End If Next i ocControl._FormComponent = _ParentComponent ocControl._ClassId = acRadioButton Select Case _ParentType Case CTLPARENTISDIALOG : Set ocControl.ControlView = _ParentComponent.getControl(ocControl._Name) Case Else : Set ocControl.ControlView = _ParentComponent.CurrentController.getControl(ocControl.ControlModel) End Select ocControl._Initialize() ocControl._DocEntry = _DocEntry ocControl._DbEntry = _DbEntry Set Controls = ocControl Exit_Function: Utils._ResetCalledSub("OptionGroup.Controls") Exit Function Trace_Error_Index: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) Set Controls = Nothing Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "OptionGroup.Controls", Erl) Set Controls = Nothing GoTo Exit_Function End Function ' Controls REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant ' Return property value of psProperty property name Utils._SetCalledSub("OptionGroup.getProperty") If IsMissing(pvProperty) Then Call _TraceArguments() getProperty = _PropertyGet(pvProperty) Utils._ResetCalledSub("OptionGroup.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 setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean ' Return True if property setting OK Utils._SetCalledSub("OptionGroup.setProperty") setProperty = _PropertySet(psProperty, pvValue) Utils._ResetCalledSub("OptionGroup.setProperty") End Function REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant _PropertiesList = Array("Count", "Name", "ObjectType", "Value") End Function ' _PropertiesList REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertyGet(ByVal psProperty As String) As Variant ' Return property value of the psProperty property name If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("OptionGroup.get" & psProperty) 'Execute Dim oDatabase As Object, vBookmark As Variant, vEMPTY As Variant Dim iValue As Integer, i As Integer _PropertyGet = vEMPTY Select Case UCase(psProperty) Case UCase("Count") _PropertyGet = _Count Case UCase("Name") _PropertyGet = _Name Case UCase("ObjectType") _PropertyGet = _Type Case UCase("Value") iValue = -1 For i = 0 To _Count - 1 ' Find the selected RadioButton If _ButtonsGroup(i).State = 1 Then iValue = _ButtonsIndex(i) Exit For End If Next i _PropertyGet = iValue Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub("OptionGroup.get" & psProperty) Exit Function Trace_Error: TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) _PropertyGet = vEMPTY Goto Exit_Function Trace_Error_Index: TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) _PropertyGet = vEMPTY Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "OptionGroup._PropertyGet", Erl) _PropertyGet = vEMPTY GoTo Exit_Function End Function ' _PropertyGet REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean Utils._SetCalledSub("OptionGroup.set" & psProperty) If _ErrorHandler() Then On Local Error Goto Error_Function _PropertySet = True 'Execute Dim i As Integer, iRadioIndex As Integer, oModel As Object, iArgNr As Integer If _IsLeft(_A2B_.CalledSub, "OptionGroup.") Then iArgNr = 1 Else iArgNr = 2 Select Case UCase(psProperty) Case UCase("Value") If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 0 Or pvValue > _Count - 1 Then Goto Trace_Error_Value For i = 0 To _Count - 1 _ButtonsGroup(i).State = 0 If _ButtonsIndex(i) = pvValue Then iRadioIndex = i Next i _ButtonsGroup(iRadioIndex).State = 1 Set oModel = _ButtonsGroup(iRadioIndex) If Utils._hasUNOProperty(oModel, "DataField") Then If Not IsNull(oModel.Datafield) And Not IsEmpty(oModel.Datafield) Then If oModel.Datafield <> "" And Utils._hasUNOMethod(oModel, "commit") Then oModel.commit() ' f.i. checkboxes have no commit method ?? [PASTIM] End If End If Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub("OptionGroup.set" & psProperty) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) _PropertySet = False Goto Exit_Function Trace_Error_Value: TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) _PropertySet = False Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "OptionGroup._PropertySet", Erl) _PropertySet = False GoTo Exit_Function End Function ' _PropertySet </script:module>