wizards/source/access2base/OptionGroup.xba

   1 <?xml version="1.0" encoding="UTF-8"?>
   2 <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
   3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="OptionGroup" script:language="StarBasic">REM =======================================================================================================================
   4 REM ===                                 The Access2Base library is a part of the LibreOffice project.                                                                   ===
   5 REM ===                                 Full documentation is available on http://www.access2base.com                                                                   ===
   6 REM =======================================================================================================================
   7
   8 Option Compatible
   9 Option ClassModule
  10
  11 Option Explicit
  12
  13 REM -----------------------------------------------------------------------------------------------------------------------
  14 REM --- CLASS ROOT FIELDS                                                                                                                                                                                       ---
  15 REM -----------------------------------------------------------------------------------------------------------------------
  16
  17 Private _Type                                   As String                               &apos;  Must be FORM
  18 Private _Name                                   As String
  19 Private _ParentType                             As String
  20 Private _ParentComponent                As Object
  21 Private _DocEntry                               As Integer
  22 Private _DbEntry                                As Integer
  23 Private _ButtonsGroup()                 As Variant
  24 Private _ButtonsIndex()                 As Variant
  25 Private _Count                                  As Long
  26
  27 REM -----------------------------------------------------------------------------------------------------------------------
  28 REM --- CONSTRUCTORS / DESTRUCTORS                                                                                                                                                                      ---
  29 REM -----------------------------------------------------------------------------------------------------------------------
  30 Private Sub Class_Initialize()
  31         _Type = OBJOPTIONGROUP
  32         _Name = &quot;&quot;
  33         _ParentType = &quot;&quot;
  34         _ParentComponent = Nothing
  35         _DocEntry = -1
  36         _DbEntry = -1
  37         _ButtonsGroup = Array()
  38         _ButtonsIndex = Array()
  39         _Count = 0
  40 End Sub         &apos;  Constructor
  41
  42 REM -----------------------------------------------------------------------------------------------------------------------
  43 Private Sub Class_Terminate()
  44         On Local Error Resume Next
  45         Call Class_Initialize()
  46 End Sub         &apos;  Destructor
  47
  48 REM -----------------------------------------------------------------------------------------------------------------------
  49 Public Sub Dispose()
  50         Call Class_Terminate()
  51 End Sub         &apos;  Explicit destructor
  52
  53 REM -----------------------------------------------------------------------------------------------------------------------
  54 REM --- CLASS GET/LET/SET PROPERTIES                                                                                                                                                            ---
  55 REM -----------------------------------------------------------------------------------------------------------------------
  56 Property Get Count() As Variant
  57         Count = _PropertyGet(&quot;Count&quot;)
  58 End Property    &apos;  Count (get)
  59
  60 REM -----------------------------------------------------------------------------------------------------------------------
  61 Property Get Name() As String
  62         Name = _PropertyGet(&quot;Name&quot;)
  63 End Property    &apos;  Name (get)
  64
  65 Public Function pName() As String               &apos;  For compatibility with &lt; V0.9.0
  66         pName = _PropertyGet(&quot;Name&quot;)
  67 End Function    &apos;  pName (get)
  68
  69 REM -----------------------------------------------------------------------------------------------------------------------
  70 Property Get ObjectType() As String
  71         ObjectType = _PropertyGet(&quot;ObjectType&quot;)
  72 End Property            &apos;  ObjectType (get)
  73
  74 REM -----------------------------------------------------------------------------------------------------------------------
  75 Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
  76 &apos;  Return
  77 &apos;          a Collection object if pvIndex absent
  78 &apos;          a Property object otherwise
  79
  80 Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
  81         vPropertiesList = _PropertiesList()
  82         sObject = Utils._PCase(_Type)
  83         If IsMissing(pvIndex) Then
  84                 vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList)
  85         Else
  86                 vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
  87                 vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
  88         End If
  89
  90 Exit_Function:
  91         Set Properties = vProperty
  92         Exit Function
  93 End Function    &apos;  Properties
  94
  95 REM -----------------------------------------------------------------------------------------------------------------------
  96 Property Get Value() As Variant
  97         Value = _PropertyGet(&quot;Value&quot;)
  98 End Property    &apos;  Value (get)
  99
 100 Property Let Value(ByVal pvValue As Variant)
 101         Call _PropertySet(&quot;Value&quot;, pvValue)
 102 End Property    &apos;  Value (set)
 103
 104 REM -----------------------------------------------------------------------------------------------------------------------
 105 REM --- CLASS METHODS                                                                                                                                                                                           ---
 106 REM -----------------------------------------------------------------------------------------------------------------------
 107 Public Function Controls(Optional ByVal pvIndex As Variant) As Variant
 108 &apos;  Return a Control object with name or index = pvIndex
 109
 110 If _ErrorHandler() Then On Local Error Goto Error_Function
 111         Utils._SetCalledSub(&quot;OptionGroup.Controls&quot;)
 112
 113 Dim ocControl As Variant, iArgNr As Integer, i As Integer
 114
 115         Set ocControl = Nothing
 116
 117         If IsMissing(pvIndex) Then                                      &apos;  No argument, return Collection object
 118                 Set oCounter = New Collect
 119                 oCounter._SubType = OBJCONTROL
 120                 oCounter._ParentType = OBJOPTIONGROUP
 121                 oCounter._ParentName = _Name
 122                 oCounter._Count = _Count
 123                 Set Controls = oCounter
 124                 Goto Exit_Function
 125         End If
 126
 127         If _IsLeft(_A2B_.CalledSub, &quot;OptionGroup.&quot;) Then iArgNr = 1 Else iArgNr = 2
 128         If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function
 129         If pvIndex &lt; 0 Or pvIndex &gt; _Count - 1 Then Goto Trace_Error_Index
 130
 131         &apos;  Start building the ocControl object
 132         &apos;  Determine exact name
 133         Set ocControl = New Control
 134         ocControl._ParentType = CTLPARENTISGROUP
 135
 136         ocControl._Shortcut = &quot;&quot;
 137         For i = 0 To _Count - 1
 138                 If _ButtonsIndex(i) = pvIndex Then
 139                         Set ocControl.ControlModel = _ButtonsGroup(i)
 140                         Select Case _ParentType
 141                                 Case CTLPARENTISDIALOG          :       ocControl._Name = _ButtonsGroup(i).Name
 142                                 Case Else                                       :       ocControl._Name = _Name                 &apos;  OptionGroup and individual radio buttons share the same name
 143                         End Select
 144                         ocControl._ImplementationName = ocControl.ControlModel.getImplementationName()
 145                         Exit For
 146                 End If
 147         Next i
 148         ocControl._FormComponent = _ParentComponent
 149         ocControl._ClassId = acRadioButton
 150         Select Case _ParentType
 151                 Case CTLPARENTISDIALOG          :       Set ocControl.ControlView = _ParentComponent.getControl(ocControl._Name)
 152                 Case Else                                       :       Set ocControl.ControlView = _ParentComponent.CurrentController.getControl(ocControl.ControlModel)
 153         End Select
 154
 155         ocControl._Initialize()
 156         ocControl._DocEntry = _DocEntry
 157         ocControl._DbEntry = _DbEntry
 158         Set Controls = ocControl
 159
 160 Exit_Function:
 161         Utils._ResetCalledSub(&quot;OptionGroup.Controls&quot;)
 162         Exit Function
 163 Trace_Error_Index:
 164         TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
 165         Set Controls = Nothing
 166         Goto Exit_Function
 167 Error_Function:
 168         TraceError(TRACEABORT, Err, &quot;OptionGroup.Controls&quot;, Erl)
 169         Set Controls = Nothing
 170         GoTo Exit_Function
 171 End Function            &apos;  Controls
 172
 173 REM -----------------------------------------------------------------------------------------------------------------------
 174 Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
 175 &apos;  Return property value of psProperty property name
 176
 177         Utils._SetCalledSub(&quot;OptionGroup.getProperty&quot;)
 178         If IsMissing(pvProperty) Then Call _TraceArguments()
 179         getProperty = _PropertyGet(pvProperty)
 180         Utils._ResetCalledSub(&quot;OptionGroup.getProperty&quot;)
 181
 182 End Function            &apos;  getProperty
 183
 184 REM -----------------------------------------------------------------------------------------------------------------------
 185 Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
 186 &apos;  Return True if object has a valid property called pvProperty (case-insensitive comparison !)
 187
 188         If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
 189         Exit Function
 190
 191 End Function    &apos;  hasProperty
 192
 193 REM -----------------------------------------------------------------------------------------------------------------------
 194 Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
 195 &apos;  Return True if property setting OK
 196         Utils._SetCalledSub(&quot;OptionGroup.setProperty&quot;)
 197         setProperty = _PropertySet(psProperty, pvValue)
 198         Utils._ResetCalledSub(&quot;OptionGroup.setProperty&quot;)
 199 End Function
 200
 201 REM -----------------------------------------------------------------------------------------------------------------------
 202 REM --- PRIVATE FUNCTIONS                                                                                                                                                                                       ---
 203 REM -----------------------------------------------------------------------------------------------------------------------
 204 REM -----------------------------------------------------------------------------------------------------------------------
 205 Private Function _PropertiesList() As Variant
 206
 207         _PropertiesList =  Array(&quot;Count&quot;, &quot;Name&quot;, &quot;ObjectType&quot;, &quot;Value&quot;)
 208
 209 End Function    &apos;  _PropertiesList
 210
 211 REM -----------------------------------------------------------------------------------------------------------------------
 212 Private Function _PropertyGet(ByVal psProperty As String) As Variant
 213 &apos;  Return property value of the psProperty property name
 214
 215         If _ErrorHandler() Then On Local Error Goto Error_Function
 216         Utils._SetCalledSub(&quot;OptionGroup.get&quot; &amp; psProperty)
 217
 218 &apos;Execute
 219 Dim oDatabase As Object, vBookmark As Variant, vEMPTY As Variant
 220 Dim iValue As Integer, i As Integer
 221         _PropertyGet = vEMPTY
 222         Select Case UCase(psProperty)
 223                 Case UCase(&quot;Count&quot;)
 224                         _PropertyGet = _Count
 225                 Case UCase(&quot;Name&quot;)
 226                         _PropertyGet = _Name
 227                 Case UCase(&quot;ObjectType&quot;)
 228                         _PropertyGet = _Type
 229                 Case UCase(&quot;Value&quot;)
 230                         iValue = -1
 231                         For i = 0 To _Count - 1                 &apos;  Find the selected RadioButton
 232                                 If _ButtonsGroup(i).State = 1 Then
 233                                         iValue = _ButtonsIndex(i)
 234                                         Exit For
 235                                 End If
 236                         Next i
 237                         _PropertyGet = iValue
 238                 Case Else
 239                         Goto Trace_Error
 240         End Select
 241
 242 Exit_Function:
 243         Utils._ResetCalledSub(&quot;OptionGroup.get&quot; &amp; psProperty)
 244         Exit Function
 245 Trace_Error:
 246         TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
 247         _PropertyGet = vEMPTY
 248         Goto Exit_Function
 249 Trace_Error_Index:
 250         TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty)
 251         _PropertyGet = vEMPTY
 252         Goto Exit_Function
 253 Error_Function:
 254         TraceError(TRACEABORT, Err, &quot;OptionGroup._PropertyGet&quot;, Erl)
 255         _PropertyGet = vEMPTY
 256         GoTo Exit_Function
 257 End Function            &apos;  _PropertyGet
 258
 259 REM -----------------------------------------------------------------------------------------------------------------------
 260 Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
 261
 262         Utils._SetCalledSub(&quot;OptionGroup.set&quot; &amp; psProperty)
 263         If _ErrorHandler() Then On Local Error Goto Error_Function
 264         _PropertySet = True
 265
 266 &apos;Execute
 267 Dim i As Integer, iRadioIndex As Integer, oModel As Object, iArgNr As Integer
 268
 269         If _IsLeft(_A2B_.CalledSub, &quot;OptionGroup.&quot;) Then iArgNr = 1 Else iArgNr = 2
 270         Select Case UCase(psProperty)
 271                 Case UCase(&quot;Value&quot;)
 272                         If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
 273                         If pvValue &lt; 0 Or pvValue &gt; _Count - 1 Then Goto Trace_Error_Value
 274                         For i = 0 To _Count - 1
 275                                 _ButtonsGroup(i).State = 0
 276                                 If _ButtonsIndex(i) = pvValue Then iRadioIndex = i
 277                         Next i
 278                         _ButtonsGroup(iRadioIndex).State = 1
 279                         Set oModel = _ButtonsGroup(iRadioIndex)
 280                         If Utils._hasUNOProperty(oModel, &quot;DataField&quot;) Then
 281                                 If Not IsNull(oModel.Datafield) And Not IsEmpty(oModel.Datafield) Then
 282                                         If oModel.Datafield &lt;&gt; &quot;&quot; And Utils._hasUNOMethod(oModel, &quot;commit&quot;) Then oModel.commit()      &apos;  f.i. checkboxes have no commit method ?? [PASTIM]
 283                                 End If
 284                         End If
 285                 Case Else
 286                         Goto Trace_Error
 287         End Select
 288
 289 Exit_Function:
 290         Utils._ResetCalledSub(&quot;OptionGroup.set&quot; &amp; psProperty)
 291         Exit Function
 292 Trace_Error:
 293         TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
 294         _PropertySet = False
 295         Goto Exit_Function
 296 Trace_Error_Value:
 297         TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
 298         _PropertySet = False
 299         Goto Exit_Function
 300 Error_Function:
 301         TraceError(TRACEABORT, Err, &quot;OptionGroup._PropertySet&quot;, Erl)
 302         _PropertySet = False
 303         GoTo Exit_Function
 304 End Function            &apos;  _PropertySet
 305 </script:module>