wizards/source/access2base/DataDef.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="DataDef" 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 TABLEDEF or QUERYDEF
  19 Private _This                                   As Object                               &apos;  Workaround for absence of This builtin function
  20 Private _Parent                                 As Object
  21 Private _Name                                   As String                               &apos;  For tables: [[Catalog.]Schema.]Table
  22 Private _ParentDatabase                 As Object
  23 Private _ReadOnly                               As Boolean
  24 Private Table                                   As Object                               &apos;  com.sun.star.sdb.dbaccess.ODBTable
  25 Private CatalogName                             As String
  26 Private SchemaName                              As String
  27 Private TableName                               As String
  28 Private Query                                   As Object                               &apos;  com.sun.star.sdb.dbaccess.OQuery
  29 Private TableDescriptor                 As Object                               &apos;  com.sun.star.sdb.dbaccess.ODBTable
  30 Private TableFieldsCount                As Integer
  31 Private TableKeysCount                  As Integer
  32
  33 REM -----------------------------------------------------------------------------------------------------------------------
  34 REM --- CONSTRUCTORS / DESTRUCTORS                                                                                                                                                                      ---
  35 REM -----------------------------------------------------------------------------------------------------------------------
  36 Private Sub Class_Initialize()
  37         _Type = &quot;&quot;
  38         Set _This = Nothing
  39         Set _Parent = Nothing
  40         _Name = &quot;&quot;
  41         Set _ParentDatabase = Nothing
  42         _ReadOnly = False
  43         Set Table = Nothing
  44         CatalogName = &quot;&quot;
  45         SchemaName = &quot;&quot;
  46         TableName = &quot;&quot;
  47         Set Query = Nothing
  48         Set TableDescriptor = Nothing
  49         TableFieldsCount = 0
  50         TableKeysCount = 0
  51 End Sub         &apos;  Constructor
  52
  53 REM -----------------------------------------------------------------------------------------------------------------------
  54 Private Sub Class_Terminate()
  55         On Local Error Resume Next
  56         Call Class_Initialize()
  57 End Sub         &apos;  Destructor
  58
  59 REM -----------------------------------------------------------------------------------------------------------------------
  60 Public Sub Dispose()
  61         Call Class_Terminate()
  62 End Sub         &apos;  Explicit destructor
  63
  64 REM -----------------------------------------------------------------------------------------------------------------------
  65 REM --- CLASS GET/LET/SET PROPERTIES                                                                                                                                                            ---
  66 REM -----------------------------------------------------------------------------------------------------------------------
  67
  68 Property Get Name() As String
  69         Name = _PropertyGet(&quot;Name&quot;)
  70 End Property            &apos;  Name (get)
  71
  72 REM -----------------------------------------------------------------------------------------------------------------------
  73 Property Get ObjectType() As String
  74         ObjectType = _PropertyGet(&quot;ObjectType&quot;)
  75 End Property            &apos;  ObjectType (get)
  76
  77 REM -----------------------------------------------------------------------------------------------------------------------
  78 Property Get SQL() As Variant
  79         SQL = _PropertyGet(&quot;SQL&quot;)
  80 End Property            &apos;  SQL (get)
  81
  82 Property Let SQL(ByVal pvValue As Variant)
  83         Call _PropertySet(&quot;SQL&quot;, pvValue)
  84 End Property            &apos;  SQL (set)
  85
  86 REM -----------------------------------------------------------------------------------------------------------------------
  87 Public Function pType() As Integer
  88         pType = _PropertyGet(&quot;Type&quot;)
  89 End Function            &apos;  Type (get)
  90
  91 REM -----------------------------------------------------------------------------------------------------------------------
  92 REM --- CLASS METHODS                                                                                                                                                                                           ---
  93 REM -----------------------------------------------------------------------------------------------------------------------
  94
  95 Public Function CreateField(ByVal Optional pvFieldName As Variant _
  96                                                                 , ByVal optional pvType As Variant _
  97                                                                 , ByVal optional pvSize As Variant _
  98                                                                 , ByVal optional pvAttributes As Variant _
  99                                                                 ) As Object
 100 &apos;Return a Field object
 101 Const cstThisSub = &quot;TableDef.CreateField&quot;
 102         Utils._SetCalledSub(cstThisSub)
 103
 104         If _ErrorHandler() Then On Local Error Goto Error_Function
 105
 106 Dim oTable As Object, oNewField As Object, oKeys As Object, oPrimaryKey As Object, oColumn As Object
 107 Const cstMaxKeyLength = 30
 108
 109         CreateField = Nothing
 110         If _ParentDatabase._DbConnect &lt;&gt; DBCONNECTBASE Then Goto Error_NotApplicable
 111         If IsMissing(pvFieldName) Then Call _TraceArguments()
 112         If Not Utils._CheckArgument(pvFieldName, 1, vbString) Then Goto Exit_Function
 113         If pvFieldName = &quot;&quot; Then Call _TraceArguments()
 114         If IsMissing(pvType) Then Call _TraceArguments()
 115         If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric( _
 116                                                 dbInteger, dbLong, dbBigInt, dbFloat, vbSingle, dbDouble _
 117                                                 , dbNumeric, dbDecimal, dbText, dbChar, dbMemo _
 118                                                 , dbDate, dbTime, dbTimeStamp _
 119                                                 , dbBinary, dbVarBinary, dbLongBinary, dbBoolean _
 120                                         )) Then Goto Exit_Function
 121         If IsMissing(pvSize) Then pvSize = 0
 122         If pvSize &lt; 0 Then pvSize = 0
 123         If Not Utils._CheckArgument(pvSize, 1, Utils._AddNumeric()) Then Goto Exit_Function
 124         If IsMissing(pvAttributes) Then pvAttributes = 0
 125         If Not Utils._CheckArgument(pvAttributes, 1, Utils._AddNumeric(), Array(0, dbAutoIncrField)) Then Goto Exit_Function
 126
 127         If _Type &lt;&gt; OBJTABLEDEF Then Goto Error_NotApplicable
 128         If IsNull(Table) And IsNull(TableDescriptor) Then Goto Error_NotApplicable
 129
 130         If _ReadOnly Then Goto Error_NoUpdate
 131
 132         Set oNewField = New Field
 133         With oNewField
 134                 ._This = oNewField
 135                 ._Name = pvFieldName
 136                 ._ParentName = _Name
 137                 ._ParentType = OBJTABLEDEF
 138                 If IsNull(Table) Then Set oTable = TableDescriptor Else Set oTable = Table
 139                 Set .Column = oTable.Columns.createDataDescriptor()
 140         End With
 141         With oNewField.Column
 142                 .Name = pvFieldName
 143                 Select Case pvType
 144                         Case dbInteger                          :       .Type = com.sun.star.sdbc.DataType.TINYINT
 145                         Case dbLong                                     :       .Type = com.sun.star.sdbc.DataType.INTEGER
 146                         Case dbBigInt                           :       .Type = com.sun.star.sdbc.DataType.BIGINT
 147                         Case dbFloat                            :       .Type = com.sun.star.sdbc.DataType.FLOAT
 148                         Case dbSingle                           :       .Type = com.sun.star.sdbc.DataType.REAL
 149                         Case dbDouble                           :       .Type = com.sun.star.sdbc.DataType.DOUBLE
 150                         Case dbNumeric, dbCurrency      :       .Type = com.sun.star.sdbc.DataType.NUMERIC
 151                         Case dbDecimal                          :       .Type = com.sun.star.sdbc.DataType.DECIMAL
 152                         Case dbText                                     :       .Type = com.sun.star.sdbc.DataType.CHAR
 153                         Case dbChar                                     :       .Type = com.sun.star.sdbc.DataType.VARCHAR
 154                         Case dbMemo                                     :       .Type = com.sun.star.sdbc.DataType.LONGVARCHAR
 155                         Case dbDate                                     :       .Type = com.sun.star.sdbc.DataType.DATE
 156                         Case dbTime                                     :       .Type = com.sun.star.sdbc.DataType.TIME
 157                         Case dbTimeStamp                        :       .Type = com.sun.star.sdbc.DataType.TIMESTAMP
 158                         Case dbBinary                           :       .Type = com.sun.star.sdbc.DataType.BINARY
 159                         Case dbVarBinary                        :       .Type = com.sun.star.sdbc.DataType.VARBINARY
 160                         Case dbLongBinary                       :       .Type = com.sun.star.sdbc.DataType.LONGVARBINARY
 161                         Case dbBoolean                          :       .Type = com.sun.star.sdbc.DataType.BOOLEAN
 162                 End Select
 163                 .Precision = Int(pvSize)
 164                 If pvType = dbNumeric Or pvType = dbDecimal Or pvType = dbCurrency Then .Scale = Int(pvSize * 10) - Int(pvSize) * 10
 165                 .IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
 166                 If Utils._hasUNOProperty(oNewField.Column, &quot;CatalogName&quot;) Then .CatalogName = CatalogName
 167                 If Utils._hasUNOProperty(oNewField.Column, &quot;SchemaName&quot;) Then .SchemaName = SchemaName
 168                 If Utils._hasUNOProperty(oNewField.Column, &quot;TableName&quot;) Then .TableName = TableName
 169                 If Not IsNull(TableDescriptor) Then TableFieldsCount = TableFieldsCount + 1
 170                 If pvAttributes = dbAutoIncrField Then
 171                         If Not IsNull(Table) Then Goto Error_Sequence                   &apos;  Do not accept adding an AutoValue field when table exists
 172                         Set oKeys = oTable.Keys
 173                         Set oPrimaryKey = oKeys.createDataDescriptor()
 174                         Set oColumn = oPrimaryKey.Columns.createDataDescriptor()
 175                         oColumn.Name = pvFieldName
 176                         oColumn.CatalogName = CatalogName
 177                         oColumn.SchemaName = SchemaName
 178                         oColumn.TableName = TableName
 179                         oColumn.IsAutoIncrement = True
 180                         oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
 181                         oPrimaryKey.Columns.appendByDescriptor(oColumn)
 182                         oPrimaryKey.Name = Left(&quot;PK_&quot; &amp; Join(Split(TableName, &quot; &quot;), &quot;_&quot;) &amp; &quot;_&quot; &amp; Join(Split(pvFieldName, &quot; &quot;), &quot;_&quot;), cstMaxKeyLength)
 183                         oPrimaryKey.Type = com.sun.star.sdbcx.KeyType.PRIMARY
 184                         oKeys.appendByDescriptor(oPrimaryKey)
 185                         .IsAutoIncrement = True
 186                         .IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
 187                         oColumn.dispose()
 188                 Else
 189                         .IsAutoIncrement = False
 190                 End If
 191         End With
 192         oTable.Columns.appendByDescriptor(oNewfield.Column)
 193
 194         Set CreateField = oNewField
 195
 196 Exit_Function:
 197         Utils._ResetCalledSub(cstThisSub)
 198         Exit Function
 199 Error_Function:
 200         TraceError(TRACEABORT, Err, cstThisSub, Erl)
 201         GoTo Exit_Function
 202 Error_NotApplicable:
 203         TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
 204         Goto Exit_Function
 205 Error_Sequence:
 206         TraceError(TRACEFATAL, ERRFIELDCREATION, Utils._CalledSub(), 0, 1, pvFieldName)
 207         Goto Exit_Function
 208 Error_NoUpdate:
 209         TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
 210         Goto Exit_Function
 211 End Function    &apos;  CreateField     V1.1.0
 212
 213 REM -----------------------------------------------------------------------------------------------------------------------
 214 Public Function Execute(ByVal Optional pvOptions As Variant) As Boolean
 215 &apos;Execute a stored query. The query must be an ACTION query.
 216
 217 Dim cstThisSub As String
 218         cstThisSub = Utils._PCase(_Type) &amp; &quot;.Execute&quot;
 219         Utils._SetCalledSub(cstThisSub)
 220         On Local Error Goto Error_Function
 221 Const cstNull = -1
 222         Execute = False
 223         If _Type &lt;&gt; OBJQUERYDEF Then Goto Trace_Method
 224         If IsMissing(pvOptions) Then
 225                 pvOptions = cstNull
 226         Else
 227                 If Not Utils._CheckArgument(pvOptions, 1, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
 228         End If
 229
 230         &apos;Check action query
 231 Dim oStatement As Object, vResult As Variant
 232 Dim iType As Integer, sSql As String
 233         iType = pType
 234         If ( (iType And DBQAction) = 0 ) And ( (iType And DBQDDL) = 0 ) Then Goto Trace_Action
 235
 236         &apos;Execute action query
 237         Set oStatement = _ParentDatabase.Connection.createStatement()
 238         sSql = Query.Command
 239         If pvOptions = dbSQLPassThrough Then oStatement.EscapeProcessing = False _
 240                                                                         Else oStatement.EscapeProcessing = Query.EscapeProcessing
 241         On Local Error Goto SQL_Error
 242         vResult = oStatement.executeUpdate(_ParentDatabase._ReplaceSquareBrackets(sSql))
 243         On Local Error Goto Error_Function
 244
 245         Execute = True
 246
 247 Exit_Function:
 248         Utils._ResetCalledSub(cstThisSub)
 249         Exit Function
 250 Trace_Method:
 251         TraceError(TRACEFATAL, ERRMETHOD, cstThisSub, 0, , cstThisSub)
 252         Goto Exit_Function
 253 Trace_Action:
 254         TraceError(TRACEFATAL, ERRNOTACTIONQUERY, cstThisSub, 0, , _Name)
 255         Goto Exit_Function
 256 SQL_Error:
 257         TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , sSql)
 258         Goto Exit_Function
 259 Error_Function:
 260         TraceError(TRACEABORT, Err, cstThisSub, Erl)
 261         GoTo Exit_Function
 262 End Function            &apos;  Execute V1.1.0
 263
 264 REM -----------------------------------------------------------------------------------------------------------------------
 265 Public Function Fields(ByVal Optional pvIndex As Variant) As Object
 266
 267         If _ErrorHandler() Then On Local Error Goto Error_Function
 268 Dim cstThisSub As String
 269         cstThisSub = Utils._PCase(_Type) &amp; &quot;.Fields&quot;
 270         Utils._SetCalledSub(cstThisSub)
 271
 272         Set Fields = Nothing
 273         If Not IsMissing(pvIndex) Then
 274                 If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
 275         End If
 276
 277 Dim sObjects() As String, sObjectName As String, oObject As Object
 278 Dim i As Integer, bFound As Boolean, oFields As Object
 279
 280         If _Type = OBJTABLEDEF Then Set oFields = Table.getColumns() Else Set oFields = Query.getColumns()
 281         sObjects = oFields.ElementNames()
 282         Select Case True
 283                 Case IsMissing(pvIndex)
 284                         Set oObject = New Collect
 285                         Set oObject._This = oObject
 286                         oObject._CollType = COLLFIELDS
 287                         Set oObject._Parent = _This
 288                         oObject._Count = UBound(sObjects) + 1
 289                         Goto Exit_Function
 290                 Case VarType(pvIndex) = vbString
 291                         bFound = False
 292                 &apos;  Check existence of object and find its exact (case-sensitive) name
 293                         For i = 0 To UBound(sObjects)
 294                                 If UCase(pvIndex) = UCase(sObjects(i)) Then
 295                                         sObjectName = sObjects(i)
 296                                         bFound = True
 297                                         Exit For
 298                                 End If
 299                         Next i
 300                         If Not bFound Then Goto Trace_NotFound
 301                 Case Else               &apos;  pvIndex is numeric
 302                         If pvIndex &lt; 0 Or pvIndex &gt; UBound(sObjects) Then Goto Trace_IndexError
 303                         sObjectName = sObjects(pvIndex)
 304         End Select
 305
 306         Set oObject = New Field
 307         Set oObject._This = oObject
 308         oObject._Name = sObjectName
 309         Set oObject.Column = oFields.getByName(sObjectName)
 310         oObject._ParentName = _Name
 311         oObject._ParentType = _Type
 312         Set oObject._ParentDatabase = _ParentDatabase
 313
 314 Exit_Function:
 315         Set Fields = oObject
 316         Set oObject = Nothing
 317         Utils._ResetCalledSub(cstThisSub)
 318         Exit Function
 319 Error_Function:
 320         TraceError(TRACEABORT, Err, cstThisSub, Erl)
 321         GoTo Exit_Function
 322 Trace_NotFound:
 323         TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(&quot;FIELD&quot;), pvIndex))
 324         Goto Exit_Function
 325 Trace_IndexError:
 326         TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
 327         Goto Exit_Function
 328 End Function            &apos;  Fields
 329
 330 REM -----------------------------------------------------------------------------------------------------------------------
 331 Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
 332 &apos;  Return property value of psProperty property name
 333
 334 Dim cstThisSub As String
 335         cstThisSub = Utils._PCase(_Type) &amp; &quot;.getProperty&quot;
 336         Utils._SetCalledSub(cstThisSub)
 337         If IsMissing(pvProperty) Then Call _TraceArguments()
 338         getProperty = _PropertyGet(pvProperty)
 339         Utils._ResetCalledSub(cstThisSub)
 340
 341 End Function            &apos;  getProperty
 342
 343 REM -----------------------------------------------------------------------------------------------------------------------
 344 Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
 345 &apos;  Return True if object has a valid property called pvProperty (case-insensitive comparison !)
 346
 347 Dim cstThisSub As String
 348         cstThisSub = Utils._PCase(_Type) &amp; &quot;.hasProperty&quot;
 349         Utils._SetCalledSub(cstThisSub)
 350         If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
 351         Utils._ResetCalledSub(cstThisSub)
 352         Exit Function
 353
 354 End Function    &apos;  hasProperty
 355
 356 REM -----------------------------------------------------------------------------------------------------------------------
 357 Public Function OpenRecordset(ByVal Optional pvType As Variant, ByVal Optional pvOptions As Variant, ByVal Optional pvLockEdit As Variant) As Object
 358 &apos;Return a Recordset object based on current table- or querydef object
 359
 360 Dim cstThisSub As String
 361         cstThisSub = Utils._PCase(_Type) &amp; &quot;.OpenRecordset&quot;
 362         Utils._SetCalledSub(cstThisSub)
 363 Const cstNull = -1
 364 Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As Boolean
 365 Dim iType As Integer, iOptions As Integer, iLockEdit As Integer
 366
 367
 368         Set oObject = Nothing
 369         If VarType(pvType) = vbError Then
 370                 iType = cstNull
 371         ElseIf IsMissing(pvType) Then
 372                 iType = cstNull
 373         Else
 374                 If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function
 375                 iType = pvType
 376         End If
 377         If VarType(pvOptions) = vbError Then
 378                 iOptions = cstNull
 379         ElseIf IsMissing(pvOptions) Then
 380                 iOptions = cstNull
 381         Else
 382                 If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
 383                 iOptions = pvOptions
 384         End If
 385         If VarType(pvLockEdit) = vbError Then
 386                 iLockEdit = cstNull
 387         ElseIf IsMissing(pvLockEdit) Then
 388                 iLockEdit = cstNull
 389         Else
 390                 If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function
 391                 iLockEdit = pvLockEdit
 392         End If
 393
 394         Select Case _Type
 395                 Case OBJTABLEDEF
 396                         lCommandType = com.sun.star.sdb.CommandType.TABLE
 397                         sCommand = _Name
 398                 Case OBJQUERYDEF
 399                         lCommandType = com.sun.star.sdb.CommandType.QUERY
 400                         sCommand = _Name
 401                         If iOptions = dbSQLPassThrough Then bPassThrough = True Else bPassThrough = Not Query.EscapeProcessing
 402         End Select
 403
 404         Set oObject = New Recordset
 405         With oObject
 406                 ._CommandType = lCommandType
 407                 ._Command = sCommand
 408                 ._ParentName = _Name
 409                 ._ParentType = _Type
 410                 ._ForwardOnly = ( iType = dbOpenForwardOnly )
 411                 ._PassThrough = bPassThrough
 412                 ._ReadOnly = ( (iLockEdit = dbReadOnly) Or _ReadOnly )
 413                 Set ._ParentDatabase = _ParentDatabase
 414                 Set ._This = oObject
 415                 Call ._Initialize()
 416         End With
 417         With _ParentDatabase
 418                 .RecordsetMax = .RecordsetMax + 1
 419                 oObject._Name = Format(.RecordsetMax, &quot;0000000&quot;)
 420                 .RecordsetsColl.Add(oObject, UCase(oObject._Name))
 421         End With
 422
 423         If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst()               &apos;  Do nothing if resultset empty
 424
 425 Exit_Function:
 426         Set OpenRecordset = oObject
 427         Set oObject = Nothing
 428         Utils._ResetCalledSub(cstThisSub)
 429         Exit Function
 430 Error_Function:
 431         TraceError(TRACEABORT, Err, cstThisSub, Erl)
 432         Set oObject = Nothing
 433         GoTo Exit_Function
 434 End Function    &apos;  OpenRecordset V1.1.0
 435
 436 REM -----------------------------------------------------------------------------------------------------------------------
 437 Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
 438 &apos;  Return
 439 &apos;          a Collection object if pvIndex absent
 440 &apos;          a Property object otherwise
 441
 442 Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
 443 Dim cstThisSub As String
 444         cstThisSub = Utils._PCase(_Type) &amp; &quot;.Properties&quot;
 445         Utils._SetCalledSub(cstThisSub)
 446         vPropertiesList = _PropertiesList()
 447         sObject = Utils._PCase(_Type)
 448         If IsMissing(pvIndex) Then
 449                 vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
 450         Else
 451                 vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
 452                 vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
 453         End If
 454         Set vProperty._ParentDatabase = _ParentDatabase
 455
 456 Exit_Function:
 457         Set Properties = vProperty
 458         Utils._ResetCalledSub(cstThisSub)
 459         Exit Function
 460 End Function    &apos;  Properties
 461
 462 REM -----------------------------------------------------------------------------------------------------------------------
 463 Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
 464 &apos;  Return True if property setting OK
 465 Dim cstThisSub As String
 466         cstThisSub = Utils._PCase(_Type) &amp; &quot;.setProperty&quot;
 467         Utils._SetCalledSub(cstThisSub)
 468         setProperty = _PropertySet(psProperty, pvValue)
 469         Utils._ResetCalledSub(cstThisSub)
 470 End Function
 471
 472 REM -----------------------------------------------------------------------------------------------------------------------
 473 REM --- PRIVATE FUNCTIONS                                                                                                                                                                                       ---
 474 REM -----------------------------------------------------------------------------------------------------------------------
 475
 476 REM -----------------------------------------------------------------------------------------------------------------------
 477 Private Function _PropertiesList() As Variant
 478
 479         Select Case _Type
 480                 Case OBJTABLEDEF
 481                         _PropertiesList = Array(&quot;Name&quot;, &quot;ObjectType&quot;)
 482                 Case OBJQUERYDEF
 483                         _PropertiesList = Array(&quot;Name&quot;, &quot;ObjectType&quot;, &quot;SQL&quot;, &quot;Type&quot;)
 484                 Case Else
 485         End Select
 486
 487 End Function    &apos;  _PropertiesList
 488
 489 REM -----------------------------------------------------------------------------------------------------------------------
 490 Private Function _PropertyGet(ByVal psProperty As String) As Variant
 491 &apos;  Return property value of the psProperty property name
 492
 493         If _ErrorHandler() Then On Local Error Goto Error_Function
 494 Dim cstThisSub As String
 495         cstThisSub = Utils._PCase(_Type)
 496         Utils._SetCalledSub(cstThisSub &amp; &quot;.get&quot; &amp; psProperty)
 497 Dim sSql As String, sVerb As String, iType As Integer
 498         _PropertyGet = EMPTY
 499         If Not hasProperty(psProperty) Then Goto Trace_Error
 500
 501         Select Case UCase(psProperty)
 502                 Case UCase(&quot;Name&quot;)
 503                         _PropertyGet = _Name
 504                 Case UCase(&quot;ObjectType&quot;)
 505                         _PropertyGet = _Type
 506                 Case UCase(&quot;SQL&quot;)
 507                         _PropertyGet = Query.Command
 508                 Case UCase(&quot;Type&quot;)
 509                         iType = 0
 510                         sSql = Utils._Trim(UCase(Query.Command))
 511                         sVerb = Split(sSql, &quot; &quot;)(0)
 512                         If sVerb = &quot;SELECT&quot; Then iType = iType + dbQSelect
 513                         If sVerb = &quot;SELECT&quot; And InStr(sSql, &quot; INTO &quot;) &gt; 0 _
 514                         Or sVerb = &quot;CREATE&quot; And InStr(sSql, &quot; TABLE &quot;) &gt; 0 _
 515                                 Then iType = iType + dbQMakeTable
 516                         If sVerb = &quot;SELECT&quot; And InStr(sSql, &quot; UNION &quot;) &gt; 0 Then iType = iType + dbQSetOperation
 517                         If Not Query.EscapeProcessing Then iType = iType + dbQSQLPassThrough
 518                         If sVerb = &quot;INSERT&quot; Then iType = iType + dbQAppend
 519                         If sVerb = &quot;DELETE&quot; Then iType = iType + dbQDelete
 520                         If sVerb = &quot;UPDATE&quot; Then iType = iType + dbQUpdate
 521                         If sVerb = &quot;CREATE&quot; _
 522                                 Or sVerb = &quot;ALTER&quot; _
 523                                 Or sVerb = &quot;DROP&quot; _
 524                                 Or sVerb = &quot;RENAME&quot; _
 525                                 Or sVerb = &quot;TRUNCATE&quot; _
 526                                         Then iType = iType + dbQDDL
 527                         &apos; dbQAction implied by dbQMakeTable, dbQAppend, dbQDelete and dbQUpdate
 528                         &apos; To check Type use: If (iType And dbQxxx) &lt;&gt; 0 Then ...
 529                         _PropertyGet = iType
 530                 Case Else
 531                         Goto Trace_Error
 532         End Select
 533
 534 Exit_Function:
 535         Utils._ResetCalledSub(cstThisSub &amp; &quot;.get&quot; &amp; psProperty)
 536         Exit Function
 537 Trace_Error:
 538         TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
 539         _PropertyGet = EMPTY
 540         Goto Exit_Function
 541 Error_Function:
 542         TraceError(TRACEABORT, Err, cstThisSub &amp; &quot;._PropertyGet&quot;, Erl)
 543         _PropertyGet = EMPTY
 544         GoTo Exit_Function
 545 End Function            &apos;  _PropertyGet
 546
 547 REM -----------------------------------------------------------------------------------------------------------------------
 548 Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
 549 &apos;  Return True if property setting OK
 550
 551         If _ErrorHandler() Then On Local Error Goto Error_Function
 552 Dim cstThisSub As String
 553         cstThisSub = Utils._PCase(_Type)
 554         Utils._SetCalledSub(cstThisSub &amp; &quot;.set&quot; &amp; psProperty)
 555
 556 &apos;Execute
 557 Dim iArgNr As Integer
 558
 559         _PropertySet = True
 560         Select Case UCase(_A2B_.CalledSub)
 561                 Case UCase(&quot;setProperty&quot;)                                             :       iArgNr = 3
 562                 Case UCase(cstThisSub &amp; &quot;.setProperty&quot;)                   :       iArgNr = 2
 563                 Case UCase(cstThisSub &amp; &quot;.set&quot; &amp; psProperty)  :       iArgNr = 1
 564         End Select
 565
 566         If Not hasProperty(psProperty) Then Goto Trace_Error
 567
 568         If _ReadOnly Then Goto Error_NoUpdate
 569
 570         Select Case UCase(psProperty)
 571                 Case UCase(&quot;SQL&quot;)
 572                         If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
 573                         Query.Command = pvValue
 574                 Case Else
 575                         Goto Trace_Error
 576         End Select
 577
 578 Exit_Function:
 579         Utils._ResetCalledSub(cstThisSub &amp; &quot;.set&quot; &amp; psProperty)
 580         Exit Function
 581 Trace_Error:
 582         TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
 583         _PropertySet = False
 584         Goto Exit_Function
 585 Trace_Error_Value:
 586         TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
 587         _PropertySet = False
 588         Goto Exit_Function
 589 Error_NoUpdate:
 590         TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
 591         Goto Exit_Function
 592 Error_Function:
 593         TraceError(TRACEABORT, Err, cstThisSub &amp; &quot;._PropertySet&quot;, Erl)
 594         _PropertySet = False
 595         GoTo Exit_Function
 596 End Function                    &apos;  _PropertySet
 597
 598 </script:module>