wizards/source/access2base/Collect.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="Collect" 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 MODULE NAME &lt;&gt; COLLECTION (seems a reserved name ?)
  14
  15 REM -----------------------------------------------------------------------------------------------------------------------
  16 REM --- CLASS ROOT FIELDS                                                                                                                                                                                       ---
  17 REM -----------------------------------------------------------------------------------------------------------------------
  18
  19 Private _Type                   As String               &apos;  Must be COLLECTION
  20 Private _CollType               As String
  21 Private _ParentType             As String
  22 Private _ParentName             As String               &apos;  Name or shortcut
  23 Private _ParentDatabase As Object
  24 Private _Count                  As Long
  25
  26 REM -----------------------------------------------------------------------------------------------------------------------
  27 REM --- CONSTRUCTORS / DESTRUCTORS                                                                                                                                                                      ---
  28 REM -----------------------------------------------------------------------------------------------------------------------
  29 Private Sub Class_Initialize()
  30         _Type = OBJCOLLECTION
  31         _CollType = &quot;&quot;
  32         _ParentType = &quot;&quot;
  33         _ParentName = &quot;&quot;
  34         Set _ParentDatabase = Nothing
  35         _Count = 0
  36 End Sub         &apos;  Constructor
  37
  38 REM -----------------------------------------------------------------------------------------------------------------------
  39 Private Sub Class_Terminate()
  40         On Local Error Resume Next
  41         Call Class_Initialize()
  42 End Sub         &apos;  Destructor
  43
  44 REM -----------------------------------------------------------------------------------------------------------------------
  45 Public Sub Dispose()
  46         Call Class_Terminate()
  47 End Sub         &apos;  Explicit destructor
  48
  49 REM -----------------------------------------------------------------------------------------------------------------------
  50 REM --- CLASS GET/LET/SET PROPERTIES                                                                                                                                                            ---
  51 REM -----------------------------------------------------------------------------------------------------------------------
  52
  53 Property Get Count() As Long
  54         Count = _PropertyGet(&quot;Count&quot;)
  55 End Property            &apos;  Count (get)
  56
  57 REM -----------------------------------------------------------------------------------------------------------------------
  58 Property Get Item(ByVal Optional pvItem As Variant) As Variant
  59 &apos;Return property value.
  60 &apos;pvItem either numeric index or property name
  61
  62 Const cstThisSub = &quot;Collection.getItem&quot;
  63         Utils._SetCalledSub(cstThisSub)
  64         If IsMissing(pvItem) Then Goto Exit_Function    &apos;  To allow object watching in Basic IDE, do not generate error
  65         Select Case _CollType
  66                 Case COLLCOMMANDBARCONTROLS                                     &apos;  Have no name
  67                         If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric()) Then Goto Exit_Function
  68                 Case Else
  69                         If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
  70         End Select
  71
  72 Dim vNames() As Variant, oProperty As Object
  73
  74         Set Item = Nothing
  75         Select Case _CollType
  76                 Case COLLALLDIALOGS
  77                         Set Item = Application.AllDialogs(pvItem)
  78                 Case COLLALLFORMS
  79                         Set Item = Application.AllForms(pvItem)
  80                 Case COLLCOMMANDBARS
  81                         Set Item = Application.CommandBars(pvItem)
  82                 Case COLLCOMMANDBARCONTROLS
  83                         Set Item = Application.CommandBars(_ParentName).CommandBarControls(pvItem)
  84                 Case COLLCONTROLS
  85                         Select Case _ParentType
  86                                 Case OBJCONTROL, OBJSUBFORM
  87                                         Set Item = getObject(_ParentName).Controls(pvItem)
  88                                 Case OBJDIALOG
  89                                         Set Item = Application.AllDialogs(_ParentName).Controls(pvItem)
  90                                 Case OBJFORM
  91                                         Set Item = Application.Forms(_ParentName).Controls(pvItem)
  92                                 Case OBJOPTIONGROUP
  93                                         &apos; NOT SUPPORTED
  94                         End Select
  95                 Case COLLFORMS
  96                         Set Item = Application.Forms(pvItem)
  97                 Case COLLFIELDS
  98                         Select Case _ParentType
  99                                 Case OBJQUERYDEF
 100                                         Set Item = _ParentDatabase.QueryDefs(_ParentName).Fields(pvItem)
 101                                 Case OBJRECORDSET
 102                                         Set Item = _ParentDatabase.Recordsets(_ParentName).Fields(pvItem)
 103                                 Case OBJTABLEDEF
 104                                         Set Item = _ParentDatabase.TableDefs(_ParentName).Fields(pvItem)
 105                         End Select
 106                 Case COLLPROPERTIES
 107                         Select Case _ParentType
 108                                 Case OBJCONTROL, OBJSUBFORM
 109                                         Set Item = getObject(_ParentName).Properties(pvItem)
 110                                 Case OBJDATABASE
 111                                         Set Item = _ParentDatabase.Properties(pvItem)
 112                                 Case OBJDIALOG
 113                                         Set Item = Application.AllDialogs(_ParentName).Properties(pvItem)
 114                                 Case OBJFIELD
 115                                         vNames() = Split(_ParentName, &quot;/&quot;)
 116                                         Select Case vNames(0)
 117                                                 Case OBJQUERYDEF
 118                                                         Set Item = _ParentDatabase.QueryDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
 119                                                 Case OBJRECORDSET
 120                                                         Set Item = _ParentDatabase.Recordsets(vNames(1)).Fields(vNames(2)).Properties(pvItem)
 121                                                 Case OBJTABLEDEF
 122                                                         Set Item = _ParentDatabase.TableDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
 123                                         End Select
 124                                 Case OBJFORM
 125                                         Set Item = Application.Forms(_ParentName).Properties(pvItem)
 126                                 Case OBJQUERYDEF
 127                                         Set Item = _ParentDatabase.QueryDefs(_ParentName).Properties(pvItem)
 128                                 Case OBJRECORDSET
 129                                         Set Item = _ParentDatabase.Recordsets(_ParentName).Properties(pvItem)
 130                                 Case OBJTABLEDEF
 131                                         Set Item = _ParentDatabase.TableDefs(_ParentName).Properties(pvItem)
 132                                 Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY
 133                                         &apos; NOT SUPPORTED
 134                         End Select
 135                 Case COLLQUERYDEFS
 136                         Set Item = _ParentDatabase.QueryDefs(pvItem)
 137                 Case COLLRECORDSETS
 138                         Set Item = _ParentDatabase.Recordsets(pvItem)
 139                 Case COLLTABLEDEFS
 140                         Set Item = _ParentDatabase.TableDefs(pvItem)
 141                 Case COLLTEMPVARS
 142                         Set Item = Application.TempVars(pvItem)
 143                 Case Else
 144         End Select
 145
 146 Exit_Function:
 147         Utils._ResetCalledSub(cstThisSub)
 148         Exit Property
 149 Error_Function:
 150         TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
 151         Set Item = Nothing
 152         GoTo Exit_Function
 153 End Property            &apos;  V1.1.0
 154
 155 REM -----------------------------------------------------------------------------------------------------------------------
 156 Property Get ObjectType() As String
 157         ObjectType = _PropertyGet(&quot;ObjectType&quot;)
 158 End Property            &apos;  ObjectType (get)
 159
 160 REM -----------------------------------------------------------------------------------------------------------------------
 161 Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
 162 &apos;  Return
 163 &apos;          a Collection object if pvIndex absent
 164 &apos;          a Property object otherwise
 165
 166 Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
 167         vPropertiesList = _PropertiesList()
 168         sObject = Utils._PCase(_Type)
 169         If IsMissing(pvIndex) Then
 170                 vProperty = PropertiesGet._Properties(sObject, _ParentName, vPropertiesList)
 171         Else
 172                 vProperty = PropertiesGet._Properties(sObject, _ParentName, vPropertiesList, pvIndex)
 173                 vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
 174         End If
 175
 176 Exit_Function:
 177         Set Properties = vProperty
 178         Exit Function
 179 End Function    &apos;  Properties
 180
 181 REM -----------------------------------------------------------------------------------------------------------------------
 182 REM --- CLASS METHODS                                                                                                                                                                                           ---
 183 REM -----------------------------------------------------------------------------------------------------------------------
 184
 185 Public Function Add(Optional pvNew As Variant, Optional pvValue As Variant) As Boolean
 186 &apos;  Append a new TableDef or TempVar object to the TableDefs/TempVars collections
 187
 188 Const cstThisSub = &quot;Collection.Add&quot;
 189         Utils._SetCalledSub(cstThisSub)
 190         If _ErrorHandler() Then On Local Error Goto Error_Function
 191
 192 Dim odbDatabase As Object, oConnection As Object, oTables As Object, oTable As Object
 193 Dim vObject As Variant, oTempVar As Object
 194         Add = False
 195         If IsMissing(pvNew) Then Call _TraceArguments()
 196
 197         Select Case _CollType
 198                 Case COLLTABLEDEFS
 199                         If Not Utils._CheckArgument(pvNew, 1, vbObject) Then Goto Exit_Function
 200                         Set vObject = pvNew
 201                         With vObject
 202                                 Set odbDatabase = ._ParentDatabase
 203                                 If odbDatabase._DbConnect &lt;&gt; DBCONNECTBASE Then Goto Error_NotApplicable
 204                                 Set oConnection = odbDatabase.Connection
 205                                 If IsNull(.TableDescriptor) Or .TableFieldsCount = 0 Then Goto Error_Sequence
 206                                 Set oTables = oConnection.getTables()
 207                                 oTables.appendByDescriptor(.TableDescriptor)
 208                                 Set .Table = oTables.getByName(._Name)
 209                                 .TableDescriptor.dispose()
 210                                 Set .TableDescriptor = Nothing
 211                                 .TableFieldsCount = 0
 212                                 .TableKeysCount = 0
 213                         End With
 214                 Case COLLTEMPVARS
 215                         If Not Utils._CheckArgument(pvNew, 1, vbString) Then Goto Exit_Function
 216                         If pvNew = &quot;&quot; Then Goto Error_Name
 217                         If IsMissing(pvValue) Then Call _TraceArguments()
 218                         If _A2B_.hasItem(COLLTEMPVARS, pvNew) Then Goto Error_Name
 219                         Set oTempVar = New TempVar
 220                         oTempVar._Name = pvNew
 221                         oTempVar._Value = pvValue
 222                         _A2B_.TempVars.Add(oTempVar, UCase(pvNew))
 223                 Case Else
 224                         Goto Error_NotApplicable
 225         End Select
 226
 227         _Count = _Count + 1
 228         Add = True
 229
 230 Exit_Function:
 231         Utils._ResetCalledSub(cstThisSub)
 232         Exit Function
 233 Error_Function:
 234         TraceError(TRACEABORT, Err, cstThisSub, Erl)
 235         GoTo Exit_Function
 236 Error_NotApplicable:
 237         TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
 238         Goto Exit_Function
 239 Error_Sequence:
 240         TraceError(TRACEFATAL, ERRTABLECREATION, Utils._CalledSub(), 0, 1, vObject._Name)
 241         Goto Exit_Function
 242 Error_Name:
 243         TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvNew))
 244         AddItem = False
 245         Goto Exit_Function
 246 End Function            &apos;  Add     V1.1.0
 247
 248 REM -----------------------------------------------------------------------------------------------------------------------
 249 Public Function Delete(ByVal Optional pvName As Variant) As Boolean
 250 &apos;  Delete a TableDef or QueryDef object in the TableDefs/QueryDefs collections
 251
 252 Const cstThisSub = &quot;Collection.Delete&quot;
 253         Utils._SetCalledSub(cstThisSub)
 254         If _ErrorHandler() Then On Local Error Goto Error_Function
 255
 256 Dim odbDatabase As Object, oColl As Object, vName As Variant
 257         Delete = False
 258         If IsMissing(pvName) Then pvName = &quot;&quot;
 259         If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function
 260         If pvName = &quot;&quot; Then Call _TraceArguments()
 261
 262         Select Case _CollType
 263                 Case COLLTABLEDEFS, COLLQUERYDEFS
 264                         If _A2B_.CurrentDocIndex() &lt;&gt; 0 Then Goto Error_NotApplicable
 265                         Set odbDatabase = Application._CurrentDb()
 266                         If odbDatabase._DbConnect &lt;&gt; DBCONNECTBASE Then Goto Error_NotApplicable
 267                         If _CollType = COLLTABLEDEFS Then Set oColl = odbDatabase.Connection.getTables() Else Set oColl = odbDatabase.Connection.getQueries()
 268                         With oColl
 269                                 vName = _InList(pvName, .getElementNames(), True)
 270                                 If vName = False Then Goto trace_NotFound
 271                                 .dropByName(vName)
 272                         End With
 273                         odbDatabase.Document.store()
 274                 Case Else
 275                         Goto Error_NotApplicable
 276         End Select
 277
 278         _Count = _Count - 1
 279         Delete = True
 280
 281 Exit_Function:
 282         Utils._ResetCalledSub(cstThisSub)
 283         Exit Function
 284 Error_Function:
 285         TraceError(TRACEABORT, Err, cstThisSub, Erl)
 286         GoTo Exit_Function
 287 Error_NotApplicable:
 288         TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
 289         Goto Exit_Function
 290 Trace_NotFound:
 291         TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Left(_CollType, 5)), pvName))
 292         Goto Exit_Function
 293 End Function            &apos;  Delete  V1.1.0
 294
 295 REM -----------------------------------------------------------------------------------------------------------------------
 296 Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
 297 &apos;  Return property value of psProperty property name
 298
 299         Utils._SetCalledSub(&quot;Collection.getProperty&quot;)
 300         If IsMissing(pvProperty) Then Call _TraceArguments()
 301         getProperty = _PropertyGet(pvProperty)
 302         Utils._ResetCalledSub(&quot;Collection.getProperty&quot;)
 303
 304 End Function            &apos;  getProperty
 305
 306 REM -----------------------------------------------------------------------------------------------------------------------
 307 Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
 308 &apos;  Return True if object has a valid property called pvProperty (case-insensitive comparison !)
 309
 310         If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
 311         Exit Function
 312
 313 End Function    &apos;  hasProperty
 314
 315 REM -----------------------------------------------------------------------------------------------------------------------
 316 Public Function Remove(ByVal Optional pvName As Variant) As Boolean
 317 &apos;  Remove a TempVar from the TempVars collection
 318
 319 Const cstThisSub = &quot;Collection.Remove&quot;
 320         Utils._SetCalledSub(cstThisSub)
 321         If _ErrorHandler() Then On Local Error Goto Error_Function
 322
 323 Dim oColl As Object, vName As Variant
 324         Remove = False
 325         If IsMissing(pvName) Then pvName = &quot;&quot;
 326         If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function
 327         If pvName = &quot;&quot; Then Call _TraceArguments()
 328
 329         Select Case _CollType
 330                 Case COLLTEMPVARS
 331                         If Not _A2B_.hasItem(COLLTEMPVARS, pvName) Then Goto Error_Name
 332                         _A2B_.TempVars.Remove(UCase(pvName))
 333                 Case Else
 334                         Goto Error_NotApplicable
 335         End Select
 336
 337         _Count = _Count - 1
 338         Remove = True
 339
 340 Exit_Function:
 341         Utils._ResetCalledSub(cstThisSub)
 342         Exit Function
 343 Error_Function:
 344         TraceError(TRACEABORT, Err, cstThisSub, Erl)
 345         GoTo Exit_Function
 346 Error_NotApplicable:
 347         TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
 348         Goto Exit_Function
 349 Error_Name:
 350         TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvName))
 351         AddItem = False
 352         Goto Exit_Function
 353 End Function            &apos;  Remove  V1.2.0
 354
 355 REM -----------------------------------------------------------------------------------------------------------------------
 356 Public Function RemoveAll() As Boolean
 357 &apos;  Remove the whole TempVars collection
 358
 359 Const cstThisSub = &quot;Collection.Remove&quot;
 360         Utils._SetCalledSub(cstThisSub)
 361         If _ErrorHandler() Then On Local Error Goto Error_Function
 362
 363         Select Case _CollType
 364                 Case COLLTEMPVARS
 365                         Set _A2B_.TempVars = New Collection
 366                         _Count = 0
 367                 Case Else
 368                         Goto Error_NotApplicable
 369         End Select
 370
 371 Exit_Function:
 372         Utils._ResetCalledSub(cstThisSub)
 373         Exit Function
 374 Error_Function:
 375         TraceError(TRACEABORT, Err, cstThisSub, Erl)
 376         GoTo Exit_Function
 377 Error_NotApplicable:
 378         TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
 379         Goto Exit_Function
 380 End Function    &apos;  RemoveAll V1.2.0
 381
 382 REM -----------------------------------------------------------------------------------------------------------------------
 383 REM --- PRIVATE FUNCTIONS                                                                                                                                                                                       ---
 384 REM -----------------------------------------------------------------------------------------------------------------------
 385 Private Function _PropertiesList() As Variant
 386          _PropertiesList = Array(&quot;Count&quot;, &quot;Item&quot;, &quot;ObjectType&quot;)
 387 End Function    &apos;  _PropertiesList
 388
 389 REM -----------------------------------------------------------------------------------------------------------------------
 390 Private Function _PropertyGet(ByVal psProperty As String) As Variant
 391 &apos;  Return property value of the psProperty property name
 392
 393         If _ErrorHandler() Then On Local Error Goto Error_Function
 394         Utils._SetCalledSub(&quot;Collection.get&quot; &amp; psProperty)
 395         _PropertyGet = Nothing
 396
 397         Select Case UCase(psProperty)
 398                 Case UCase(&quot;Count&quot;)
 399                         _PropertyGet = _Count
 400                 Case UCase(&quot;Item&quot;)
 401                 Case UCase(&quot;ObjectType&quot;)
 402                         _PropertyGet = _Type
 403                 Case Else
 404                         Goto Trace_Error
 405         End Select
 406
 407 Exit_Function:
 408         Utils._ResetCalledSub(&quot;Collection.get&quot; &amp; psProperty)
 409         Exit Function
 410 Trace_Error:
 411         TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
 412         _PropertyGet = Nothing
 413         Goto Exit_Function
 414 Error_Function:
 415         TraceError(TRACEABORT, Err, &quot;Collection._PropertyGet&quot;, Erl)
 416         _PropertyGet = Nothing
 417         GoTo Exit_Function
 418 End Function            &apos;  _PropertyGet
 419 </script:module>