diff options
Diffstat (limited to 'wizards/source/access2base/OptionGroup.xba')
| -rw-r--r-- | wizards/source/access2base/OptionGroup.xba | 315 |
1 files changed, 315 insertions, 0 deletions
diff --git a/wizards/source/access2base/OptionGroup.xba b/wizards/source/access2base/OptionGroup.xba new file mode 100644 index 000000000..f4b749ef6 --- /dev/null +++ b/wizards/source/access2base/OptionGroup.xba @@ -0,0 +1,315 @@ +<?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 _This As Object ' Workaround for absence of This builtin function +Private _Parent As Object +Private _Name As String +Private _ParentType As String +Private _ParentComponent As Object +Private _MainForm As String +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 + Set _This = Nothing + Set _Parent = Nothing + _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, _This, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _This, 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 +Dim oCounter As Object + + Set ocControl = Nothing + + If IsMissing(pvIndex) Then ' No argument, return Collection object + Set oCounter = New Collect + Set oCounter._This = oCounter + oCounter._CollType = COLLCONTROLS + Set oCounter._Parent = _This + 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 + Set ocControl._This = ocControl + Set ocControl._Parent = _This + 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 +Dim iValue As Integer, i As Integer + _PropertyGet = EMPTY + 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 = 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, "OptionGroup._PropertyGet", Erl) + _PropertyGet = EMPTY + 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>
\ No newline at end of file |