diff options
Diffstat (limited to '')
| -rw-r--r-- | wizards/source/access2base/Field.xba | 923 |
1 files changed, 923 insertions, 0 deletions
diff --git a/wizards/source/access2base/Field.xba b/wizards/source/access2base/Field.xba new file mode 100644 index 000000000..1fe2f185e --- /dev/null +++ b/wizards/source/access2base/Field.xba @@ -0,0 +1,923 @@ +<?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>
\ No newline at end of file |