123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923 |
- <?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="Field" 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 FIELD
- Private _This As Object ' Workaround for absence of This builtin function
- Private _Parent As Object
- Private _Name As String
- Private _Precision As Long
- Private _ParentName As String
- Private _ParentType As String
- Private _ParentDatabase As Object
- Private _ParentRecordset As Object
- Private _DefaultValue As String
- Private _DefaultValueSet As Boolean
- Private Column As Object ' com.sun.star.sdb.OTableColumnWrapper
- ' or org.openoffice.comp.dbaccess.OQueryColumn
- ' or com.sun.star.sdb.ODataColumn
- REM -----------------------------------------------------------------------------------------------------------------------
- REM --- CONSTRUCTORS / DESTRUCTORS ---
- REM -----------------------------------------------------------------------------------------------------------------------
- Private Sub Class_Initialize()
- _Type = OBJFIELD
- Set _This = Nothing
- Set _Parent = Nothing
- _Name = ""
- _ParentName = ""
- _ParentType = ""
- _DefaultValue = ""
- _DefaultValueSet = False
- Set Column = Nothing
- 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 DataType() As Long ' AOO/LibO type
- DataType = _PropertyGet("DataType")
- End Property ' DataType (get)
- Property Get DataUpdatable() As Boolean
- DataUpdatable = _PropertyGet("DataUpdatable")
- End Property ' DataUpdatable (get)
- REM -----------------------------------------------------------------------------------------------------------------------
- Property Get DbType() As Long ' MSAccess type
- DbType = _PropertyGet("DbType")
- End Property ' DbType (get)
- REM -----------------------------------------------------------------------------------------------------------------------
- Property Get DefaultValue() As Variant
- DefaultValue = _PropertyGet("DefaultValue")
- End Property ' DefaultValue (get)
- Property Let DefaultValue(ByVal pvDefaultValue As Variant)
- Call _PropertySet("DefaultValue", pvDefaultValue)
- End Property ' DefaultValue (set)
- REM -----------------------------------------------------------------------------------------------------------------------
- Property Get Description() As Variant
- Description = _PropertyGet("Description")
- End Property ' Description (get)
- Property Let Description(ByVal pvDescription As Variant)
- Call _PropertySet("Description", pvDescription)
- End Property ' Description (set)
- REM -----------------------------------------------------------------------------------------------------------------------
- Property Get FieldSize() As Long
- FieldSize = _PropertyGet("FieldSize")
- End Property ' FieldSize (get)
- 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 Size() As Long
- Size = _PropertyGet("Size")
- End Property ' Size (get)
- REM -----------------------------------------------------------------------------------------------------------------------
- Property Get SourceField() As String
- SourceField = _PropertyGet("SourceField")
- End Property ' SourceField (get)
- REM -----------------------------------------------------------------------------------------------------------------------
- Property Get SourceTable() As String
- SourceTable = _PropertyGet("SourceTable")
- End Property ' SourceTable (get)
- REM -----------------------------------------------------------------------------------------------------------------------
- Property Get TypeName() As String
- TypeName = _PropertyGet("TypeName")
- End Property ' TypeName (get)
- REM -----------------------------------------------------------------------------------------------------------------------
- Property Get Value() As Variant
- Value = _PropertyGet("Value")
- End Property ' Value (get)
- Property Let Value(ByVal pvValue As Variant)
- Call _PropertySet("Value", pvValue)
- End Property ' Value (set)
- REM -----------------------------------------------------------------------------------------------------------------------
- REM --- CLASS METHODS ---
- REM -----------------------------------------------------------------------------------------------------------------------
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function AppendChunk(ByRef Optional pvValue As Variant) As Boolean
- ' Store a chunk of string or binary characters into the current field, presumably a large object (CLOB or BLOB)
- If _ErrorHandler() Then On Local Error Goto Error_Function
- Const cstThisSub = "Field.AppendChunk"
- Utils._SetCalledSub(cstThisSub)
- AppendChunk = False
- If IsMissing(pvValue) Then Call _TraceArguments()
- If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... !
- If Not Column.IsWritable Then Goto Trace_Error_Updatable
- If Column.IsReadOnly Then Goto Trace_Error_Updatable
- If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update
- Dim iChunkType As Integer
- With com.sun.star.sdbc.DataType
- Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES
- ' Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
- ' iChunkType = vbString
- Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB, .CHAR ' .CHAR added for Sqlite3
- iChunkType = vbByte
- Case Else
- Goto Trace_Error
- End Select
- End With
-
- AppendChunk = _ParentRecordset._AppendChunk(_Name, pvValue, iChunkType)
- Exit_Function:
- Utils._ResetCalledSub(cstThisSub)
- Exit Function
- Trace_Error_Update:
- TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
- _PropertySet = False
- Goto Exit_Function
- Trace_Error_Updatable:
- TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1)
- _PropertySet = False
- Goto Exit_Function
- Trace_Error:
- TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub)
- Goto Exit_Function
- Error_Function:
- TraceError(TRACEABORT, Err, cstThisSub, Erl)
- _PropertySet = False
- GoTo Exit_Function
- End Function ' AppendChunk V1.5.0
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function GetChunk(ByVal Optional pvOffset As Variant, ByVal Optional pvBytes As Variant) As Variant
- ' Get a chunk of string or binary characters from the current field, presumably a large object (CLOB or BLOB)
- If _ErrorHandler() Then On Local Error Goto Error_Function
- Const cstThisSub = "Field.GetChunk"
- Utils._SetCalledSub(cstThisSub)
- Dim oValue As Object, bNullable As Boolean, bNull As Boolean, vValue() As Variant
- Dim lLength As Long, lOffset As Long, lValue As Long
- If IsMissing(pvOffset) Or IsMissing(pvBytes) Then Call _TraceArguments()
- If Not Utils._CheckArgument(pvOffset, 1, _AddNumeric()) Then Goto Exit_Function
- If pvOffset < 0 Then
- TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvOffset))
- Goto Exit_Function
- End If
- If Not Utils._CheckArgument(pvBytes, 2, _AddNumeric()) Then Goto Exit_Function
- If pvBytes < 0 Then
- TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(2, pvBytes))
- Goto Exit_Function
- End If
- bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
- bNull = False
- GetChunk = Null
- vValue = Array()
- With com.sun.star.sdbc.DataType
- Select Case Column.Type ' DOES NOT WORK FOR CHARACTER TYPES
- ' Case .CHAR, .VARCHAR, .LONGVARCHAR
- ' Set oValue = Column.getCharacterStream()
- ' Case .CLOB
- ' Set oValue = Column.getClob.getCharacterStream()
- Case .BINARY, .VARBINARY, .LONGVARBINARY
- Set oValue = Column.getBinaryStream()
- Case .BLOB
- Set oValue = Column.getBlob.getBinaryStream()
- Case Else
- Goto Trace_Error
- End Select
- If bNullable Then bNull = Column.wasNull()
- If Not bNull Then
- lOffset = CLng(pvOffset)
- If lOffset > 0 Then oValue.skipBytes(lOffset)
- lValue = oValue.readBytes(vValue, pvBytes)
- End If
- oValue.closeInput()
- End With
- GetChunk = vValue
- Exit_Function:
- Utils._ResetCalledSub(cstThisSub)
- Exit Function
- Trace_Error:
- TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , cstThisSub)
- Goto Exit_Function
- Trace_Argument:
- TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex))
- Set vForms = Nothing
- Goto Exit_Function
- Error_Function:
- TraceError(TRACEABORT, Err, cstThisSub, Erl)
- GoTo Exit_Function
- End Function ' GetChunk V1.5.0
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
- ' Return property value of psProperty property name
- Const cstThisSub = "Field.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 !)
- Const cstThisSub = "Field.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 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, sName As String
- Const cstThisSub = "Field.Properties"
- Utils._SetCalledSub(cstThisSub)
- vPropertiesList = _PropertiesList()
- sObject = Utils._PCase(_Type)
- sName = _ParentType & "/" & _ParentName & "/" & _Name
- If IsMissing(pvIndex) Then
- vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
- Else
- vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
- vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
- Set vProperty._ParentDatabase = _ParentDatabase
- End If
-
- Exit_Function:
- Set Properties = vProperty
- Utils._ResetCalledSub(cstThisSub)
- Exit Function
- End Function ' Properties
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function ReadAllBytes(ByVal Optional pvFile As Variant) As Boolean
- ' Read the whole content of a file into Long Binary Field object
- Const cstThisSub = "Field.ReadAllBytes"
- Utils._SetCalledSub(cstThisSub)
- If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
- ReadAllBytes = _ReadAll(pvFile, "ReadAllBytes")
- Exit_Function:
- Utils._ResetCalledSub(cstThisSub)
- Exit Function
- End Function ' ReadAllBytes
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function ReadAllText(ByVal Optional pvFile As Variant) As Boolean
- ' Read the whole content of a file into a Long Char Field object
- Const cstThisSub = "Field.ReadAllText"
- Utils._SetCalledSub(cstThisSub)
- If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
- ReadAllText = _ReadAll(pvFile, "ReadAllText")
- Exit_Function:
- Utils._ResetCalledSub(cstThisSub)
- Exit Function
- End Function ' ReadAllText
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean
- ' Return True if property setting OK
- Const cstThisSub = "Field.setProperty"
- Utils._SetCalledSub(cstThisSub)
- setProperty = _PropertySet(psProperty, pvValue)
- Utils._ResetCalledSub(cstThisSub)
- End Function
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function WriteAllBytes(ByVal Optional pvFile As Variant) As Boolean
- ' Write the whole content of a Long Binary Field object to a file
- Const cstThisSub = "Field.WriteAllBytes"
- Utils._SetCalledSub(cstThisSub)
- If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
- WriteAllBytes = _WriteAll(pvFile, "WriteAllBytes")
- Exit_Function:
- Utils._ResetCalledSub(cstThisSub)
- Exit Function
- End Function ' WriteAllBytes
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function WriteAllText(ByVal Optional pvFile As Variant) As Boolean
- ' Write the whole content of a Long Char Field object to a file
- Const cstThisSub = "Field.WriteAllText"
- Utils._SetCalledSub(cstThisSub)
- If Not Utils._CheckArgument(pvFile, 1, vbString) Then Goto Exit_Function
- WriteAllText = _WriteAll(pvFile, "WriteAllText")
- Exit_Function:
- Utils._ResetCalledSub(cstThisSub)
- Exit Function
- End Function ' WriteAllText
- REM -----------------------------------------------------------------------------------------------------------------------
- REM --- PRIVATE FUNCTIONS ---
- REM -----------------------------------------------------------------------------------------------------------------------
- REM -----------------------------------------------------------------------------------------------------------------------
- Private Function _PropertiesList() As Variant
- Select Case _ParentType
- Case OBJTABLEDEF
- _PropertiesList =Array("DataType", "dbType", "DefaultValue" _
- , "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _
- , "TypeName" _
- )
- Case OBJQUERYDEF
- _PropertiesList = Array("DataType", "dbType", "DefaultValue" _
- , "Description", "Name", "ObjectType", "Size", "SourceField", "SourceTable" _
- , "TypeName" _
- )
- Case OBJRECORDSET
- _PropertiesList = Array("DataType", "DataUpdatable", "dbType", "DefaultValue" _
- , "Description" , "FieldSize", "Name", "ObjectType" _
- , "Size", "SourceTable", "TypeName", "Value" _
- )
- 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 = "Field.get" & psProperty
- Utils._SetCalledSub(cstThisSub)
- If Not hasProperty(psProperty) Then Goto Trace_Error
- Dim bCond1 As Boolean, bCond2 As Boolean, vValue As Variant, oValue As Object, sValue As String
- Dim oSize As Object, lSize As Long, bNullable As Boolean, bNull As Boolean
- Const cstMaxBinlength = 2 * 65535
- _PropertyGet = EMPTY
-
- Select Case UCase(psProperty)
- Case UCase("DataType")
- _PropertyGet = Column.Type
- Case UCase("DbType")
- With com.sun.star.sdbc.DataType
- Select Case Column.Type
- Case .BIT : _PropertyGet = dbBoolean
- Case .TINYINT : _PropertyGet = dbInteger
- Case .SMALLINT : _PropertyGet = dbLong
- Case .INTEGER : _PropertyGet = dbLong
- Case .BIGINT : _PropertyGet = dbBigInt
- Case .FLOAT : _PropertyGet = dbFloat
- Case .REAL : _PropertyGet = dbSingle
- Case .DOUBLE : _PropertyGet = dbDouble
- Case .NUMERIC : _PropertyGet = dbNumeric
- Case .DECIMAL : _PropertyGet = dbDecimal
- Case .CHAR : _PropertyGet = dbChar
- Case .VARCHAR : _PropertyGet = dbText
- Case .LONGVARCHAR : _PropertyGet = dbMemo
- Case .CLOB : _PropertyGet = dbMemo
- Case .DATE : _PropertyGet = dbDate
- Case .TIME : _PropertyGet = dbTime
- Case .TIMESTAMP : _PropertyGet = dbTimeStamp
- Case .BINARY : _PropertyGet = dbBinary
- Case .VARBINARY : _PropertyGet = dbVarBinary
- Case .LONGVARBINARY : _PropertyGet = dbLongBinary
- Case .BLOB : _PropertyGet = dbLongBinary
- Case .BOOLEAN : _PropertyGet = dbBoolean
- Case Else : _PropertyGet = dbUndefined
- End Select
- End With
- Case UCase("DataUpdatable")
- If Utils._hasUNOProperty(Column, "IsWritable") Then
- _PropertyGet = Column.IsWritable
- ElseIf Utils._hasUNOProperty(Column, "IsReadOnly") Then
- _PropertyGet = Not Column.IsReadOnly
- ElseIf Utils._hasUNOProperty(Column, "IsDefinitelyWritable") Then
- _PropertyGet = Column.IsDefinitelyWritable
- Else
- _PropertyGet = False
- End If
- If Utils._hasUNOProperty(Column, "IsAutoIncrement") Then
- If Column.IsAutoIncrement Then _PropertyGet = False ' Forces False if auto-increment (MSAccess)
- End If
- Case UCase("DefaultValue")
- ' default value buffered to avoid multiple calls
- If Not _DefaultValueSet Then
- If Utils._hasUNOProperty(Column, "DefaultValue") Then ' Default value in database set via SQL statement
- _DefaultValue = Column.DefaultValue
- ElseIf Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition
- If IsEmpty(Column.ControlDefault) Then _DefaultValue = "" Else _DefaultValue = Column.ControlDefault
- Else
- _DefaultValue = ""
- End If
- _DefaultValueSet = True
- End If
- _PropertyGet = _DefaultValue
- Case UCase("Description")
- bCond1 = Utils._hasUNOProperty(Column, "Description")
- bCond2 = Utils._hasUNOProperty(Column, "HelpText")
- Select Case True
- Case ( bCond1 And bCond2 )
- If IsEmpty(Column.HelpText) Then _PropertyGet = Column.Description Else _PropertyGet = Column.HelpText
- Case ( bCond1 And ( Not bCond2 ) )
- _PropertyGet = Column.Description
- Case ( ( Not bCond1 ) And bCond2 )
- _PropertyGet = Column.HelpText
- Case Else
- _PropertyGet = ""
- End Select
- Case UCase("FieldSize")
- With com.sun.star.sdbc.DataType
- Select Case Column.Type
- Case .VARCHAR, .LONGVARCHAR, .CLOB
- Set oSize = Column.getCharacterStream
- Case .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB
- Set oSize = Column.getBinaryStream
- Case Else
- Set oSize = Nothing
- End Select
- End With
- If Not IsNull(oSize) Then
- bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
- If bNullable Then
- If Column.wasNull() Then _PropertyGet = 0 Else _PropertyGet = CLng(oSize.getLength())
- Else
- _PropertyGet = CLng(oSize.getLength())
- End If
- oSize.closeInput()
- Else
- _PropertyGet = EMPTY
- End If
- Case UCase("Name")
- _PropertyGet = _Name
- Case UCase("ObjectType")
- _PropertyGet = _Type
- Case UCase("Size")
- With com.sun.star.sdbc.DataType
- Select Case Column.Type
- Case .LONGVARCHAR, .LONGVARBINARY, .VARBINARY, .BINARY, .BLOB, .CLOB
- _PropertyGet = 0 ' Always 0 (MSAccess)
- Case Else
- If Utils._hasUNOProperty(Column, "Precision") Then _PropertyGet = Column.Precision Else _PropertyGet = 0
- End Select
- End With
- Case UCase("SourceField")
- Select Case _ParentType
- Case OBJTABLEDEF
- _PropertyGet = _Name
- Case OBJQUERYDEF ' RealName = not documented ?!?
- If Utils._hasUNOProperty(Column, "RealName") Then _PropertyGet = Column.RealName Else _PropertyGet = _Name
- End Select
- Case UCase("SourceTable")
- Select Case _ParentType
- Case OBJTABLEDEF
- _PropertyGet = _ParentName
- Case OBJQUERYDEF, OBJRECORDSET
- _PropertyGet = Column.TableName
- End Select
- Case UCase("TypeName")
- _PropertyGet = Column.TypeName
- Case UCase("Value")
- bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
- bNull = False
- With com.sun.star.sdbc.DataType
- Select Case Column.Type
- Case .BIT, .BOOLEAN : vValue = Column.getBoolean() ' vbBoolean
- Case .TINYINT : vValue = Column.getShort() ' vbInteger
- Case .SMALLINT, .INTEGER: vValue = Column.getInt() ' vbLong
- Case .BIGINT : vValue = Column.getLong() ' vbBigint
- Case .FLOAT : vValue = Column.getFloat() ' vbSingle
- Case .REAL, .DOUBLE : vValue = Column.getDouble() ' vbDouble
- Case .NUMERIC, .DECIMAL
- If Utils._hasUNOProperty(Column, "Scale") Then
- If Column.Scale > 0 Then
- vValue = Column.getDouble()
- Else ' Try Long otherwise Double (CDec not implemented anymore in LO ?!?)
- On Local Error Resume Next ' Avoid overflow error
- ' CLng checks local decimal point, getString does not !
- sValue = Join(Split(Column.getString(), "."), Utils._DecimalPoint())
- vValue = CLng(sValue)
- If Err <> 0 Then
- vValue = CDbl(sValue)
- Err.Clear
- On Local Error Goto Error_Function
- End If
- End If
- Else
- vValue = CDbl(Column.getString())
- End If
- Case .CHAR : vValue = Column.getString()
- Case .VARCHAR : vValue = Column.getString() ' vbString
- Case .LONGVARCHAR, .CLOB
- Set oValue = Column.getCharacterStream()
- If bNullable Then bNull = Column.wasNull()
- If Not bNull Then
- lSize = CLng(oValue.getLength())
- oValue.closeInput()
- vValue = Column.getString() ' vbString
- Else
- oValue.closeInput()
- End If
- Case .DATE : Set oValue = Column.getDate() ' vbObject with members VarType Unsigned Short = 18
- If bNullable Then bNull = Column.wasNull()
- If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day))
- Case .TIME : Set oValue = Column.getTime() ' vbObject with members VarType Unsigned Short = 18
- If bNullable Then bNull = Column.wasNull()
- If Not bNull Then vValue = TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds)
- Case .TIMESTAMP : Set oValue = Column.getTimeStamp()
- If bNullable Then bNull = Column.wasNull()
- If Not bNull Then vValue = DateSerial(CInt(oValue.Year), CInt(oValue.Month), CInt(oValue.Day)) _
- + TimeSerial(oValue.Hours, oValue.Minutes, oValue.Seconds)', oValue.HundredthSeconds)
- Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
- Set oValue = Column.getBinaryStream()
- If bNullable Then bNull = Column.wasNull()
- If Not bNull Then
- lSize = CLng(oValue.getLength()) ' vbLong => equivalent to FieldSize
- If lSize > cstMaxBinlength Then Goto Trace_Length
- vValue = Array()
- oValue.readBytes(vValue, lSize)
- End If
- oValue.closeInput()
- Case Else
- vValue = Column.getString() 'GIVE STRING A TRY
- If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess)
- End Select
- If bNullable Then
- If Column.wasNull() Then vValue = Null 'getXXX must precede wasNull()
- End If
- End With
- _PropertyGet = vValue
- Case Else
- Goto Trace_Error
- End Select
-
- Exit_Function:
- Utils._ResetCalledSub(cstThisSub)
- Exit Function
- Trace_Error:
- TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
- _PropertyGet = EMPTY
- Goto Exit_Function
- Trace_Length:
- TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(lSize, "GetChunk"))
- _PropertyGet = EMPTY
- Goto Exit_Function
- Error_Function:
- TraceError(TRACEABORT, Err, cstThisSub, Erl)
- _PropertyGet = EMPTY
- GoTo Exit_Function
- End Function ' _PropertyGet V1.1.0
- 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 = "Field.set" & psProperty
- Utils._SetCalledSub(cstThisSub)
- _PropertySet = True
- Dim iArgNr As Integer, vTemp As Variant
- Dim oParent As Object
- Select Case UCase(_A2B_.CalledSub)
- Case UCase("setProperty") : iArgNr = 3
- Case UCase("Field.setProperty") : iArgNr = 2
- Case UCase(cstThisSub) : iArgNr = 1
- End Select
-
- If Not hasProperty(psProperty) Then Goto Trace_Error
- Select Case UCase(psProperty)
- Case UCase("DefaultValue")
- If _ParentType <> OBJTABLEDEF Then Goto Trace_Error
- If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
- If Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition
- Column.ControlDefault = pvValue
- _DefaultValue = pvValue
- _DefaultValueSet = True
- End If
- Case UCase("Description")
- If _ParentType <> OBJTABLEDEF Then Goto Trace_Error
- If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
- Column.HelpText = pvValue
- Case UCase("Value")
- If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... !
- If Not Column.IsWritable Then Goto Trace_Error_Updatable
- If Column.IsReadOnly Then Goto Trace_Error_Updatable
- If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update
- With com.sun.star.sdbc.DataType
- If IsNull(pvValue) Then
- If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then Column.updateNull() Else Goto Trace_Null
- Else
- Select Case Column.Type
- Case .BIT, .BOOLEAN
- If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
- Column.updateBoolean(pvValue)
- Case .TINYINT
- If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
- If pvValue < -128 Or pvValue > +127 Then Goto Trace_Error_Value
- Column.updateShort(CInt(pvValue))
- Case .SMALLINT
- If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
- If pvValue < -32768 Or pvValue > 32767 Then Goto trace_Error_Value
- Column.updateInt(CLng(pvValue))
- Case .INTEGER
- If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
- If pvValue < -2147483648 Or pvValue > 2147483647 Then Goto trace_Error_Value
- Column.updateInt(CLng(pvValue))
- Case .BIGINT
- If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
- Column.updateLong(pvValue) ' No proper type conversion for HYPER data type
- Case .FLOAT
- If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
- If Abs(pvValue) < 3.402823E38 And Abs(pvValue) > 1.401298E-45 Then Column.updateFloat(CSng(pvValue)) Else Goto trace_Error_Value
- Case .REAL, .DOUBLE
- If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
- 'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value
- Column.updateDouble(CDbl(pvValue))
- Case .NUMERIC, .DECIMAL
- If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
- If Utils._hasUNOProperty(Column, "Scale") Then
- If Column.Scale > 0 Then
- 'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then Column.updateDouble(CDbl(pvValue)) Else Goto trace_Error_Value
- Column.updateDouble(CDbl(pvValue))
- Else
- Column.updateString(CStr(pvValue))
- End If
- Else
- Column.updateString(CStr(pvValue))
- End If
- Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
- If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
- If _Precision > 0 And Len(pvValue) > _Precision Then Goto Trace_Error_Length
- Column.updateString(pvValue) ' vbString
- Case .DATE
- If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
- vTemp = New com.sun.star.util.Date
- With vTemp
- .Day = Day(pvValue)
- .Month = Month(pvValue)
- .Year = Year(pvValue)
- End With
- Column.updateDate(vTemp)
- Case .TIME
- If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
- vTemp = New com.sun.star.util.Time
- With vTemp
- .Hours = Hour(pvValue)
- .Minutes = Minute(pvValue)
- .Seconds = Second(pvValue)
- '.HundredthSeconds = 0 ' replaced with Long nanoSeconds in LO 4.1 ??
- End With
- Column.updateTime(vTemp)
- Case .TIMESTAMP
- If Not Utils._CheckArgument(pvValue, iArgNr, vbDate, , False) Then Goto Trace_Error_Value
- vTemp = New com.sun.star.util.DateTime
- With vTemp
- .Day = Day(pvValue)
- .Month = Month(pvValue)
- .Year = Year(pvValue)
- .Hours = Hour(pvValue)
- .Minutes = Minute(pvValue)
- .Seconds = Second(pvValue)
- '.HundredthSeconds = 0
- End With
- Column.updateTimestamp(vTemp)
- Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
- If Not IsArray(pvValue) Then Goto Trace_Error_Value
- If UBound(pvValue) < LBound(pvValue) Then Goto Trace_Error_Value
- If Not Utils._CheckArgument(pvValue(LBound(pvValue)), iArgNr, vbInteger, , False) Then Goto Trace_Error_Value
- Column.updateBytes(pvValue)
- Case Else
- Goto trace_Error
- End Select
- End If
- End With
- Case Else
- Goto Trace_Error
- End Select
-
- Exit_Function:
- Utils._ResetCalledSub(cstThisSub)
- 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
- Trace_Null:
- TraceError(TRACEFATAL, ERRNOTNULLABLE, Utils._CalledSub(), 0, 1, _Name)
- _PropertySet = False
- Goto Exit_Function
- Trace_Error_Update:
- TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
- _PropertySet = False
- Goto Exit_Function
- Trace_Error_Updatable:
- TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1)
- _PropertySet = False
- Goto Exit_Function
- Trace_Error_Length:
- TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(Len(pvValue), "AppendChunk"))
- _PropertySet = False
- Goto Exit_Function
- Error_Function:
- TraceError(TRACEABORT, Err, cstThisSub, Erl)
- _PropertySet = False
- GoTo Exit_Function
- End Function ' _PropertySet
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function _ReadAll(ByVal psFile As String, ByVal psMethod As String) As Boolean
- ' Write the whole content of a file into a stream object
- If _ErrorHandler() Then On Local Error Goto Error_Function
- _ReadAll = False
- If _ParentType <> OBJRECORDSET Then Goto Trace_Error ' Not on table- or querydefs ... !
- If Not Column.IsWritable Then Goto Trace_Error_Updatable
- If Column.IsReadOnly Then Goto Trace_Error_Updatable
- If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update
- Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object
- Dim lFileLength As Long, sBuffer As String, sMemo As String, iFile As Integer
- Const cstMaxLength = 64000
- sFile = ConvertToURL(psFile)
- oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
- If Not oSimpleFileAccess.exists(sFile) Then Goto Trace_File
- With com.sun.star.sdbc.DataType
- Select Case Column.Type
- Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
- If psMethod <> "ReadAllBytes" Then Goto Trace_Error
- Set oStream = oSimpleFileAccess.openFileRead(sFile)
- lFileLength = oStream.getLength()
- If lFileLength = 0 Then Goto Trace_File
- Column.updateBinaryStream(oStream, lFileLength)
- oStream.closeInput()
- Case .VARCHAR, .LONGVARCHAR, .CLOB
- If psMethod <> "ReadAllText" Then Goto Trace_Error
- sMemo = ""
- lFileLength = 0
- iFile = FreeFile()
- Open sFile For Input Access Read Shared As iFile
- Do While Not Eof(iFile)
- Line Input #iFile, sBuffer
- lFileLength = lFileLength + Len(sBuffer) + 1
- If lFileLength > cstMaxLength Then Exit Do
- sMemo = sMemo & sBuffer & vbNewLine
- Loop
- If lFileLength = 0 Or lFileLength > cstMaxLength Then
- Close #iFile
- Goto Trace_File
- End If
- sMemo = Left(sMemo, lFileLength - 1)
- Column.updateString(sMemo)
- 'Column.updateCharacterStream(oStream, lFileLength) ' DOES NOT WORK ?!?
- Case Else
- Goto Trace_Error
- End Select
- End With
- _ReadAll = True
-
- Exit_Function:
- Exit Function
- Trace_Error:
- TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod)
- Goto Exit_Function
- Trace_File:
- TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile)
- If Not IsNull(oStream) Then oStream.closeInput()
- Goto Exit_Function
- Trace_Error_Update:
- TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1)
- If Not IsNull(oStream) Then oStream.closeInput()
- Goto Exit_Function
- Trace_Error_Updatable:
- TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0, 1)
- If Not IsNull(oStream) Then oStream.closeInput()
- Goto Exit_Function
- Error_Function:
- TraceError(TRACEABORT, Err, _CalledSub, Erl)
- GoTo Exit_Function
- End Function ' ReadAll
- REM -----------------------------------------------------------------------------------------------------------------------
- Public Function _WriteAll(ByVal psFile As String, ByVal psMethod As String) As Boolean
- ' Write the whole content of a stream object to a file
- If _ErrorHandler() Then On Local Error Goto Error_Function
- _WriteAll = False
- Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object
- sFile = ConvertToURL(psFile)
- oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
- With com.sun.star.sdbc.DataType
- Select Case Column.Type
- Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
- If psMethod <> "WriteAllBytes" Then Goto Trace_Error
- Set oStream = Column.getBinaryStream()
- Case .VARCHAR, .LONGVARCHAR, .CLOB
- If psMethod <> "WriteAllText" Then Goto Trace_Error
- Set oStream = Column.getCharacterStream()
- Case Else
- Goto Trace_Error
- End Select
- End With
- If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then
- If Column.wasNull() Then Goto Trace_Null
- End If
- If oStream.getLength() = 0 Then Goto Trace_Null
- On Local Error Goto Trace_File
- If oSimpleFileAccess.exists(sFile) Then oSimpleFileAccess.kill(sFile)
- oSimpleFileAccess.writeFile(sFile, oStream)
- On Local Error Goto Error_Function
- oStream.closeInput()
- _WriteAll = True
-
- Exit_Function:
- Exit Function
- Trace_Error:
- TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, , psMethod)
- Goto Exit_Function
- Trace_File:
- TraceError(TRACEFATAL, ERRFILEACCESS, Utils._CalledSub(), 0, , sFile)
- If Not IsNull(oStream) Then oStream.closeInput()
- Goto Exit_Function
- Trace_Null:
- TraceError(TRACEFATAL, ERRFIELDNULL, _CalledSub, 0)
- If Not IsNull(oStream) Then oStream.closeInput()
- Goto Exit_Function
- Error_Function:
- TraceError(TRACEABORT, Err, _CalledSub, Erl)
- GoTo Exit_Function
- End Function ' WriteAll
- </script:module>
|