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