mirror of
https://gitee.com/kekingcn/file-online-preview.git
synced 2026-03-15 05:33:52 +08:00
移除office-plugin, 使用新版jodconverter
This commit is contained in:
陈精华
598
server/windows-office/share/basic/Access2Base/DataDef.xba
Normal file
598
server/windows-office/share/basic/Access2Base/DataDef.xba
Normal file
@@ -0,0 +1,598 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
|
||||
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="DataDef" script:language="StarBasic">
|
||||
REM =======================================================================================================================
|
||||
REM === The Access2Base library is a part of the LibreOffice project. ===
|
||||
REM === Full documentation is available on http://www.access2base.com ===
|
||||
REM =======================================================================================================================
|
||||
|
||||
Option Compatible
|
||||
Option ClassModule
|
||||
|
||||
Option Explicit
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS ROOT FIELDS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Private _Type As String ' Must be TABLEDEF or QUERYDEF
|
||||
Private _This As Object ' Workaround for absence of This builtin function
|
||||
Private _Parent As Object
|
||||
Private _Name As String ' For tables: [[Catalog.]Schema.]Table
|
||||
Private _ParentDatabase As Object
|
||||
Private _ReadOnly As Boolean
|
||||
Private Table As Object ' com.sun.star.sdb.dbaccess.ODBTable
|
||||
Private CatalogName As String
|
||||
Private SchemaName As String
|
||||
Private TableName As String
|
||||
Private Query As Object ' com.sun.star.sdb.dbaccess.OQuery
|
||||
Private TableDescriptor As Object ' com.sun.star.sdb.dbaccess.ODBTable
|
||||
Private TableFieldsCount As Integer
|
||||
Private TableKeysCount As Integer
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CONSTRUCTORS / DESTRUCTORS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Initialize()
|
||||
_Type = ""
|
||||
Set _This = Nothing
|
||||
Set _Parent = Nothing
|
||||
_Name = ""
|
||||
Set _ParentDatabase = Nothing
|
||||
_ReadOnly = False
|
||||
Set Table = Nothing
|
||||
CatalogName = ""
|
||||
SchemaName = ""
|
||||
TableName = ""
|
||||
Set Query = Nothing
|
||||
Set TableDescriptor = Nothing
|
||||
TableFieldsCount = 0
|
||||
TableKeysCount = 0
|
||||
End Sub ' Constructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Sub Class_Terminate()
|
||||
On Local Error Resume Next
|
||||
Call Class_Initialize()
|
||||
End Sub ' Destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Sub Dispose()
|
||||
Call Class_Terminate()
|
||||
End Sub ' Explicit destructor
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS GET/LET/SET PROPERTIES ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Property Get Name() As String
|
||||
Name = _PropertyGet("Name")
|
||||
End Property ' Name (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get ObjectType() As String
|
||||
ObjectType = _PropertyGet("ObjectType")
|
||||
End Property ' ObjectType (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Property Get SQL() As Variant
|
||||
SQL = _PropertyGet("SQL")
|
||||
End Property ' SQL (get)
|
||||
|
||||
Property Let SQL(ByVal pvValue As Variant)
|
||||
Call _PropertySet("SQL", pvValue)
|
||||
End Property ' SQL (set)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function pType() As Integer
|
||||
pType = _PropertyGet("Type")
|
||||
End Function ' Type (get)
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- CLASS METHODS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
Public Function CreateField(ByVal Optional pvFieldName As Variant _
|
||||
, ByVal optional pvType As Variant _
|
||||
, ByVal optional pvSize As Variant _
|
||||
, ByVal optional pvAttributes As variant _
|
||||
) As Object
|
||||
'Return a Field object
|
||||
Const cstThisSub = "TableDef.CreateField"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
|
||||
Dim oTable As Object, oNewField As Object, oKeys As Object, oPrimaryKey As Object, oColumn As Object
|
||||
Const cstMaxKeyLength = 30
|
||||
|
||||
CreateField = Nothing
|
||||
If _ParentDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
|
||||
If IsMissing(pvFieldName) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvFieldName, 1, vbString) Then Goto Exit_Function
|
||||
If pvFieldName = "" Then Call _TraceArguments()
|
||||
If IsMissing(pvType) Then Call _TraceArguments()
|
||||
If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric( _
|
||||
dbInteger, dbLong, dbBigInt, dbFloat, vbSingle, dbDouble _
|
||||
, dbNumeric, dbDecimal, dbText, dbChar, dbMemo _
|
||||
, dbDate, dbTime, dbTimeStamp _
|
||||
, dbBinary, dbVarBinary, dbLongBinary, dbBoolean _
|
||||
)) Then Goto Exit_Function
|
||||
If IsMissing(pvSize) Then pvSize = 0
|
||||
If pvSize < 0 Then pvSize = 0
|
||||
If Not Utils._CheckArgument(pvSize, 1, Utils._AddNumeric()) Then Goto Exit_Function
|
||||
If IsMissing(pvAttributes) Then pvAttributes = 0
|
||||
If Not Utils._CheckArgument(pvAttributes, 1, Utils._AddNumeric(), Array(0, dbAutoIncrField)) Then Goto Exit_Function
|
||||
|
||||
If _Type <> OBJTABLEDEF Then Goto Error_NotApplicable
|
||||
If IsNull(Table) And IsNull(TableDescriptor) Then Goto Error_NotApplicable
|
||||
|
||||
If _ReadOnly Then Goto Error_NoUpdate
|
||||
|
||||
Set oNewField = New Field
|
||||
With oNewField
|
||||
._This = oNewField
|
||||
._Name = pvFieldName
|
||||
._ParentName = _Name
|
||||
._ParentType = OBJTABLEDEF
|
||||
If IsNull(Table) Then Set oTable = TableDescriptor Else Set oTable = Table
|
||||
Set .Column = oTable.Columns.createDataDescriptor()
|
||||
End With
|
||||
With oNewField.Column
|
||||
.Name = pvFieldName
|
||||
Select Case pvType
|
||||
Case dbInteger : .Type = com.sun.star.sdbc.DataType.TINYINT
|
||||
Case dbLong : .Type = com.sun.star.sdbc.DataType.INTEGER
|
||||
Case dbBigInt : .Type = com.sun.star.sdbc.DataType.BIGINT
|
||||
Case dbFloat : .Type = com.sun.star.sdbc.DataType.FLOAT
|
||||
Case dbSingle : .Type = com.sun.star.sdbc.DataType.REAL
|
||||
Case dbDouble : .Type = com.sun.star.sdbc.DataType.DOUBLE
|
||||
Case dbNumeric, dbCurrency : .Type = com.sun.star.sdbc.DataType.NUMERIC
|
||||
Case dbDecimal : .Type = com.sun.star.sdbc.DataType.DECIMAL
|
||||
Case dbText : .Type = com.sun.star.sdbc.DataType.CHAR
|
||||
Case dbChar : .Type = com.sun.star.sdbc.DataType.VARCHAR
|
||||
Case dbMemo : .Type = com.sun.star.sdbc.DataType.LONGVARCHAR
|
||||
Case dbDate : .Type = com.sun.star.sdbc.DataType.DATE
|
||||
Case dbTime : .Type = com.sun.star.sdbc.DataType.TIME
|
||||
Case dbTimeStamp : .Type = com.sun.star.sdbc.DataType.TIMESTAMP
|
||||
Case dbBinary : .Type = com.sun.star.sdbc.DataType.BINARY
|
||||
Case dbVarBinary : .Type = com.sun.star.sdbc.DataType.VARBINARY
|
||||
Case dbLongBinary : .Type = com.sun.star.sdbc.DataType.LONGVARBINARY
|
||||
Case dbBoolean : .Type = com.sun.star.sdbc.DataType.BOOLEAN
|
||||
End Select
|
||||
.Precision = Int(pvSize)
|
||||
If pvType = dbNumeric Or pvType = dbDecimal Or pvType = dbCurrency Then .Scale = Int(pvSize * 10) - Int(pvSize) * 10
|
||||
.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
|
||||
If Utils._hasUNOProperty(oNewField.Column, "CatalogName") Then .CatalogName = CatalogName
|
||||
If Utils._hasUNOProperty(oNewField.Column, "SchemaName") Then .SchemaName = SchemaName
|
||||
If Utils._hasUNOProperty(oNewField.Column, "TableName") Then .TableName = TableName
|
||||
If Not IsNull(TableDescriptor) Then TableFieldsCount = TableFieldsCount + 1
|
||||
If pvAttributes = dbAutoIncrField Then
|
||||
If Not IsNull(Table) Then Goto Error_Sequence ' Do not accept adding an AutoValue field when table exists
|
||||
Set oKeys = oTable.Keys
|
||||
Set oPrimaryKey = oKeys.createDataDescriptor()
|
||||
Set oColumn = oPrimaryKey.Columns.createDataDescriptor()
|
||||
oColumn.Name = pvFieldName
|
||||
oColumn.CatalogName = CatalogName
|
||||
oColumn.SchemaName = SchemaName
|
||||
oColumn.TableName = TableName
|
||||
oColumn.IsAutoIncrement = True
|
||||
oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
|
||||
oPrimaryKey.Columns.appendByDescriptor(oColumn)
|
||||
oPrimaryKey.Name = Left("PK_" & Join(Split(TableName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength)
|
||||
oPrimaryKey.Type = com.sun.star.sdbcx.KeyType.PRIMARY
|
||||
oKeys.appendByDescriptor(oPrimaryKey)
|
||||
.IsAutoIncrement = True
|
||||
.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
|
||||
oColumn.dispose()
|
||||
Else
|
||||
.IsAutoIncrement = False
|
||||
End If
|
||||
End With
|
||||
oTable.Columns.appendByDescriptor(oNewfield.Column)
|
||||
|
||||
Set CreateField = oNewField
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
Error_NotApplicable:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
|
||||
Goto Exit_Function
|
||||
Error_Sequence:
|
||||
TraceError(TRACEFATAL, ERRFIELDCREATION, Utils._CalledSub(), 0, 1, pvFieldName)
|
||||
Goto Exit_Function
|
||||
Error_NoUpdate:
|
||||
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
End Function ' CreateField V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Execute(ByVal Optional pvOptions As Variant) As Boolean
|
||||
'Execute a stored query. The query must be an ACTION query.
|
||||
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".Execute"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
On Local Error Goto Error_Function
|
||||
Const cstNull = -1
|
||||
Execute = False
|
||||
If _Type <> OBJQUERYDEF Then Goto Trace_Method
|
||||
If IsMissing(pvOptions) Then
|
||||
pvOptions = cstNull
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvOptions, 1, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function
|
||||
End If
|
||||
|
||||
'Check action query
|
||||
Dim oStatement As Object, vResult As Variant
|
||||
Dim iType As Integer, sSql As String
|
||||
iType = pType
|
||||
If ( (iType And DBQAction) = 0 ) And ( (iType And DBQDDL) = 0 ) Then Goto Trace_Action
|
||||
|
||||
'Execute action query
|
||||
Set oStatement = _ParentDatabase.Connection.createStatement()
|
||||
sSql = Query.Command
|
||||
If pvOptions = dbSQLPassThrough Then oStatement.EscapeProcessing = False _
|
||||
Else oStatement.EscapeProcessing = Query.EscapeProcessing
|
||||
On Local Error Goto SQL_Error
|
||||
vResult = oStatement.executeUpdate(_ParentDatabase._ReplaceSquareBrackets(sSql))
|
||||
On Local Error Goto Error_Function
|
||||
|
||||
Execute = True
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Trace_Method:
|
||||
TraceError(TRACEFATAL, ERRMETHOD, cstThisSub, 0, , cstThisSub)
|
||||
Goto Exit_Function
|
||||
Trace_Action:
|
||||
TraceError(TRACEFATAL, ERRNOTACTIONQUERY, cstThisSub, 0, , _Name)
|
||||
Goto Exit_Function
|
||||
SQL_Error:
|
||||
TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , sSql)
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
End Function ' Execute V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Fields(ByVal Optional pvIndex As variant) As Object
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".Fields"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
|
||||
Set Fields = Nothing
|
||||
If Not IsMissing(pvIndex) Then
|
||||
If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
|
||||
End If
|
||||
|
||||
Dim sObjects() As String, sObjectName As String, oObject As Object
|
||||
Dim i As Integer, bFound As Boolean, oFields As Object
|
||||
|
||||
If _Type = OBJTABLEDEF Then Set oFields = Table.getColumns() Else Set oFields = Query.getColumns()
|
||||
sObjects = oFields.ElementNames()
|
||||
Select Case True
|
||||
Case IsMissing(pvIndex)
|
||||
Set oObject = New Collect
|
||||
Set oObject._This = oObject
|
||||
oObject._CollType = COLLFIELDS
|
||||
Set oObject._Parent = _This
|
||||
oObject._Count = UBound(sObjects) + 1
|
||||
Goto Exit_Function
|
||||
Case VarType(pvIndex) = vbString
|
||||
bFound = False
|
||||
' Check existence of object and find its exact (case-sensitive) name
|
||||
For i = 0 To UBound(sObjects)
|
||||
If UCase(pvIndex) = UCase(sObjects(i)) Then
|
||||
sObjectName = sObjects(i)
|
||||
bFound = True
|
||||
Exit For
|
||||
End If
|
||||
Next i
|
||||
If Not bFound Then Goto Trace_NotFound
|
||||
Case Else ' pvIndex is numeric
|
||||
If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
|
||||
sObjectName = sObjects(pvIndex)
|
||||
End Select
|
||||
|
||||
Set oObject = New Field
|
||||
Set oObject._This = oObject
|
||||
oObject._Name = sObjectName
|
||||
Set oObject.Column = oFields.getByName(sObjectName)
|
||||
oObject._ParentName = _Name
|
||||
oObject._ParentType = _Type
|
||||
Set oObject._ParentDatabase = _ParentDatabase
|
||||
|
||||
Exit_Function:
|
||||
Set Fields = oObject
|
||||
Set oObject = Nothing
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
GoTo Exit_Function
|
||||
Trace_NotFound:
|
||||
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex))
|
||||
Goto Exit_Function
|
||||
Trace_IndexError:
|
||||
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
End Function ' Fields
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
|
||||
' Return property value of psProperty property name
|
||||
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".getProperty"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvProperty) Then Call _TraceArguments()
|
||||
getProperty = _PropertyGet(pvProperty)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
|
||||
End Function ' getProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
|
||||
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
|
||||
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".hasProperty"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
|
||||
End Function ' hasProperty
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function OpenRecordset(ByVal Optional pvType As Variant, ByVal Optional pvOptions As Variant, ByVal Optional pvLockEdit As Variant) As Object
|
||||
'Return a Recordset object based on current table- or querydef object
|
||||
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".OpenRecordset"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
Const cstNull = -1
|
||||
Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As Boolean
|
||||
Dim iType As Integer, iOptions As Integer, iLockEdit As Integer
|
||||
|
||||
|
||||
Set oObject = Nothing
|
||||
If VarType(pvType) = vbError Then
|
||||
iType = cstNull
|
||||
ElseIf IsMissing(pvType) Then
|
||||
iType = cstNull
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function
|
||||
iType = pvType
|
||||
End If
|
||||
If VarType(pvOptions) = vbError Then
|
||||
iOptions = cstNull
|
||||
ElseIf IsMissing(pvOptions) Then
|
||||
iOptions = cstNull
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
|
||||
iOptions = pvOptions
|
||||
End If
|
||||
If VarType(pvLockEdit) = vbError Then
|
||||
iLockEdit = cstNull
|
||||
ElseIf IsMissing(pvLockEdit) Then
|
||||
iLockEdit = cstNull
|
||||
Else
|
||||
If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function
|
||||
iLockEdit = pvLockEdit
|
||||
End If
|
||||
|
||||
Select Case _Type
|
||||
Case OBJTABLEDEF
|
||||
lCommandType = com.sun.star.sdb.CommandType.TABLE
|
||||
sCommand = _Name
|
||||
Case OBJQUERYDEF
|
||||
lCommandType = com.sun.star.sdb.CommandType.QUERY
|
||||
sCommand = _Name
|
||||
If iOptions = dbSQLPassThrough Then bPassThrough = True Else bPassThrough = Not Query.EscapeProcessing
|
||||
End Select
|
||||
|
||||
Set oObject = New Recordset
|
||||
With oObject
|
||||
._CommandType = lCommandType
|
||||
._Command = sCommand
|
||||
._ParentName = _Name
|
||||
._ParentType = _Type
|
||||
._ForwardOnly = ( iType = dbOpenForwardOnly )
|
||||
._PassThrough = bPassThrough
|
||||
._ReadOnly = ( (iLockEdit = dbReadOnly) Or _ReadOnly )
|
||||
Set ._ParentDatabase = _ParentDatabase
|
||||
Set ._This = oObject
|
||||
Call ._Initialize()
|
||||
End With
|
||||
With _ParentDatabase
|
||||
.RecordsetMax = .RecordsetMax + 1
|
||||
oObject._Name = Format(.RecordsetMax, "0000000")
|
||||
.RecordsetsColl.Add(oObject, UCase(oObject._Name))
|
||||
End With
|
||||
|
||||
If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty
|
||||
|
||||
Exit_Function:
|
||||
Set OpenRecordset = oObject
|
||||
Set oObject = Nothing
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub, Erl)
|
||||
Set oObject = Nothing
|
||||
GoTo Exit_Function
|
||||
End Function ' OpenRecordset V1.1.0
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
|
||||
' Return
|
||||
' a Collection object if pvIndex absent
|
||||
' a Property object otherwise
|
||||
|
||||
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".Properties"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
vPropertiesList = _PropertiesList()
|
||||
sObject = Utils._PCase(_Type)
|
||||
If IsMissing(pvIndex) Then
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
|
||||
Else
|
||||
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
|
||||
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
|
||||
End If
|
||||
Set vProperty._ParentDatabase = _ParentDatabase
|
||||
|
||||
Exit_Function:
|
||||
Set Properties = vProperty
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
Exit Function
|
||||
End Function ' Properties
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type) & ".setProperty"
|
||||
Utils._SetCalledSub(cstThisSub)
|
||||
setProperty = _PropertySet(psProperty, pvValue)
|
||||
Utils._ResetCalledSub(cstThisSub)
|
||||
End Function
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
REM --- PRIVATE FUNCTIONS ---
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertiesList() As Variant
|
||||
|
||||
Select Case _Type
|
||||
Case OBJTABLEDEF
|
||||
_PropertiesList = Array("Name", "ObjectType")
|
||||
Case OBJQUERYDEF
|
||||
_PropertiesList = Array("Name", "ObjectType", "SQL", "Type")
|
||||
Case Else
|
||||
End Select
|
||||
|
||||
End Function ' _PropertiesList
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertyGet(ByVal psProperty As String) As Variant
|
||||
' Return property value of the psProperty property name
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type)
|
||||
Utils._SetCalledSub(cstThisSub & ".get" & psProperty)
|
||||
Dim sSql As String, sVerb As String, iType As Integer
|
||||
_PropertyGet = EMPTY
|
||||
If Not hasProperty(psProperty) Then Goto Trace_Error
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("Name")
|
||||
_PropertyGet = _Name
|
||||
Case UCase("ObjectType")
|
||||
_PropertyGet = _Type
|
||||
Case UCase("SQL")
|
||||
_PropertyGet = Query.Command
|
||||
Case UCase("Type")
|
||||
iType = 0
|
||||
sSql = Utils._Trim(UCase(Query.Command))
|
||||
sVerb = Split(sSql, " ")(0)
|
||||
If sVerb = "SELECT" Then iType = iType + dbQSelect
|
||||
If sVerb = "SELECT" And InStr(sSql, " INTO ") > 0 _
|
||||
Or sVerb = "CREATE" And InStr(sSql, " TABLE ") > 0 _
|
||||
Then iType = iType + dbQMakeTable
|
||||
If sVerb = "SELECT" And InStr(sSql, " UNION ") > 0 Then iType = iType + dbQSetOperation
|
||||
If Not Query.EscapeProcessing Then iType = iType + dbQSQLPassThrough
|
||||
If sVerb = "INSERT" Then iType = iType + dbQAppend
|
||||
If sVerb = "DELETE" Then iType = iType + dbQDelete
|
||||
If sVerb = "UPDATE" Then iType = iType + dbQUpdate
|
||||
If sVerb = "CREATE" _
|
||||
Or sVerb = "ALTER" _
|
||||
Or sVerb = "DROP" _
|
||||
Or sVerb = "RENAME" _
|
||||
Or sVerb = "TRUNCATE" _
|
||||
Then iType = iType + dbQDDL
|
||||
' dbQAction implied by dbQMakeTable, dbQAppend, dbQDelete and dbQUpdate
|
||||
' To check Type use: If (iType And dbQxxx) <> 0 Then ...
|
||||
_PropertyGet = iType
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub & ".get" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
||||
_PropertyGet = EMPTY
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl)
|
||||
_PropertyGet = EMPTY
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertyGet
|
||||
|
||||
REM -----------------------------------------------------------------------------------------------------------------------
|
||||
Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean
|
||||
' Return True if property setting OK
|
||||
|
||||
If _ErrorHandler() Then On Local Error Goto Error_Function
|
||||
Dim cstThisSub As String
|
||||
cstThisSub = Utils._PCase(_Type)
|
||||
Utils._SetCalledSub(cstThisSub & ".set" & psProperty)
|
||||
|
||||
'Execute
|
||||
Dim iArgNr As Integer
|
||||
|
||||
_PropertySet = True
|
||||
Select Case UCase(_A2B_.CalledSub)
|
||||
Case UCase("setProperty") : iArgNr = 3
|
||||
Case UCase(cstThisSub & ".setProperty") : iArgNr = 2
|
||||
Case UCase(cstThisSub & ".set" & psProperty) : iArgNr = 1
|
||||
End Select
|
||||
|
||||
If Not hasProperty(psProperty) Then Goto Trace_Error
|
||||
|
||||
If _ReadOnly Then Goto Error_NoUpdate
|
||||
|
||||
Select Case UCase(psProperty)
|
||||
Case UCase("SQL")
|
||||
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
|
||||
Query.Command = pvValue
|
||||
Case Else
|
||||
Goto Trace_Error
|
||||
End Select
|
||||
|
||||
Exit_Function:
|
||||
Utils._ResetCalledSub(cstThisSub & ".set" & psProperty)
|
||||
Exit Function
|
||||
Trace_Error:
|
||||
TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Trace_Error_Value:
|
||||
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
|
||||
_PropertySet = False
|
||||
Goto Exit_Function
|
||||
Error_NoUpdate:
|
||||
TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
|
||||
Goto Exit_Function
|
||||
Error_Function:
|
||||
TraceError(TRACEABORT, Err, cstThisSub & "._PropertySet", Erl)
|
||||
_PropertySet = False
|
||||
GoTo Exit_Function
|
||||
End Function ' _PropertySet
|
||||
|
||||
</script:module>
|
||||
Reference in New Issue
Block a user