diff options
Diffstat (limited to 'wizards/source/access2base/Field.xba')
| -rw-r--r-- | wizards/source/access2base/Field.xba | 738 |
1 files changed, 738 insertions, 0 deletions
diff --git a/wizards/source/access2base/Field.xba b/wizards/source/access2base/Field.xba new file mode 100644 index 000000000000..78431f564587 --- /dev/null +++ b/wizards/source/access2base/Field.xba @@ -0,0 +1,738 @@ +<?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">Option Compatible +Option ClassModule + +Option Explicit + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS ROOT FIELDS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Private _Type As String ' Must be FIELD +Private _Name As String +Private _ParentName As String +Private _ParentType As String +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 + _Name = "" + _ParentName = "" + _ParentType = "" + Set Column = Nothing +End Sub ' Constructor + +REM ----------------------------------------------------------------------------------------------------------------------- +'Private Sub Class_Terminate() + +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 String + DefaultValue = _PropertyGet("DefaultValue") +End Property ' DefaultValue (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Description() As String + Description = _PropertyGet("Description") +End Property ' Description (get) + +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 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, sName, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, sName, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + 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 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 vEMPTY As Variant, 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 cstMaxTextLength = 65535 + _PropertyGet = vEMPTY + + 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 = dbUndefined + 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 = dbText + Case .VARCHAR : _PropertyGet = dbChar + Case .LONGVARCHAR : _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 .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") + If Utils._hasUNOProperty(Column, "DefaultValue") Then ' Default value in database set via SQL statement + _PropertyGet = Column.DefaultValue + ElseIf Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition + If IsEmpty(Column.ControlDefault) Then _PropertyGet = "" Else _PropertyGet = Column.ControlDefault + Else + _PropertyGet = "" + End If + 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") ' Probably physical size = 2 * unicode string length + With com.sun.star.sdbc.DataType + Select Case Column.Type + Case .LONGVARCHAR + Set oSize = Column.getCharacterStream + Case .LONGVARBINARY, .VARBINARY, .BINARY + 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 = vEMPTY + 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 + _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 ' CDec checks local decimal point, getString does not ! + sValue = Join(Split(Column.getString(), "."), Utils._DecimalPoint()) + vValue = CDec(sValue) + End If + Else + vValue = CDec(Column.getString()) + End If + Case .CHAR : vValue = Column.getString() + Case .VARCHAR : vValue = Column.getString() ' vbString + Case .LONGVARCHAR + Set oValue = Column.getCharacterStream() + If bNullable Then bNull = Column.wasNull() + If Not bNull Then + lSize = CLng(oValue.getLength()) + oValue.closeInput() + If lSize > cstMaxTextLength Then Goto Trace_Length + 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 + Set oValue = Column.getBinaryStream() + If bNullable Then bNull = Column.wasNull() + If Not bNull Then vValue = CLng(oValue.getLength()) ' vbLong => equivalent to FieldSize + oValue.closeInput() + Case .BLOB : vValue = Column.getBlob() ' TBC HSQLDB 2.0 ? + Case .CLOB : vValue = Column.getClob() + 'getArray + 'getRef + 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 = Nothing '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(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + _PropertyGet = vEMPTY + Goto Exit_Function +Trace_Length: + TraceError(TRACEFATAL, ERRMEMOLENGTH, Utils._CalledSub(), 0, , lSize) + _PropertyGet = vEMPTY + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + _PropertyGet = vEMPTY + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean +' Return True if property setting OK + + If _ErrorHandler() Then On Local Error Goto Error_Function +Dim cstThisSub As String + cstThisSub = "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("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 Application._CurrentDb().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 + End If + 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 + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + 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 +' Case .BLOB +' Case .CLOB + Case Else + Goto trace_Error + End Select + 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 +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 Application._CurrentDb().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 + 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 .LONGVARCHAR + 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 & Chr(10) + 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 + If psMethod <> "WriteAllBytes" Then Goto Trace_Error + Set oStream = Column.getBinaryStream() + Case .LONGVARCHAR + 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 + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS PROPERTY SETs --- +REM --- Workaround to bug https://www.libreoffice.org/bugzilla/show_bug.cgi?id=60752 (LibreOffice 4.0) --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Property Set Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +</script:module>
\ No newline at end of file |