D7net
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
lib
/
libreoffice
/
share
/
basic
/
Access2Base
/
Filename :
Field.xba
back
Copy
<?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>