15fec4ee1c
To get faster access to parents from controls Top classes (form, dialog and commandbar) should return Parent = Nothing
923 lines
No EOL
38 KiB
XML
923 lines
No EOL
38 KiB
XML
<?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> |