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