[Libreoffice-commits] core.git: wizards/source
Jean-Pierre Ledure
jp at ledure.be
Wed Feb 3 11:21:17 UTC 2016
wizards/source/access2base/Application.xba | 2
wizards/source/access2base/Collect.xba | 3
wizards/source/access2base/Compatible.xba | 2
wizards/source/access2base/DataDef.xba | 17 ++-
wizards/source/access2base/Database.xba | 34 ++++--
wizards/source/access2base/Field.xba | 155 +++++++++++++++++++++++++----
wizards/source/access2base/L10N.xba | 8 -
wizards/source/access2base/Recordset.xba | 130 ++++++++++++++++++++++++
wizards/source/access2base/Utils.xba | 26 +++-
wizards/source/access2base/acConstants.xba | 2
10 files changed, 337 insertions(+), 42 deletions(-)
New commits:
commit d8a113841160c571a3f254e73b676994eb940a79
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Wed Feb 3 12:13:54 2016 +0100
Access2Base - Wider database support
Support of HSQLDB 2.3 and MySql
CLOB and BLOB as database field types
Schema and catalog names in tables
GetChunk and AppendChunk methods for binary fields
The Value property returns the correct binary content of binary fields
Change-Id: I0aba80134f9add90f438ac4b7951fce9c1d36239
diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba
index 7a76ed0..ae7483b 100644
--- a/wizards/source/access2base/Application.xba
+++ b/wizards/source/access2base/Application.xba
@@ -59,7 +59,7 @@ Global Const ERRRECORDSETCLOSED = 1538
Global Const ERRRECORDSETRANGE = 1539
Global Const ERRRECORDSETFORWARD = 1540
Global Const ERRFIELDNULL = 1541
-Global Const ERRMEMOLENGTH = 1542
+Global Const ERROVERFLOW = 1542
Global Const ERRNOTACTIONQUERY = 1543
Global Const ERRNOTUPDATABLE = 1544
Global Const ERRUPDATESEQUENCE = 1545
diff --git a/wizards/source/access2base/Collect.xba b/wizards/source/access2base/Collect.xba
index cafda77..74cd756 100644
--- a/wizards/source/access2base/Collect.xba
+++ b/wizards/source/access2base/Collect.xba
@@ -206,6 +206,9 @@ Dim vObject As Variant, oTempVar As Object
Set oTables = oConnection.getTables()
oTables.appendByDescriptor(.TableDescriptor)
Set .Table = oTables.getByName(._Name)
+ .CatalogName = .Table.CatalogName
+ .SchemaName = .Table.SchemaName
+ .TableName = .Table.Name
.TableDescriptor.dispose()
Set .TableDescriptor = Nothing
.TableFieldsCount = 0
diff --git a/wizards/source/access2base/Compatible.xba b/wizards/source/access2base/Compatible.xba
index f3d3ad9..30cab09 100644
--- a/wizards/source/access2base/Compatible.xba
+++ b/wizards/source/access2base/Compatible.xba
@@ -19,7 +19,7 @@ Dim vVarTypes() As Variant, i As Integer
Const cstTab = 5
On Local Error Goto Exit_Sub ' Never interrupt processing
Utils._SetCalledSub("DebugPrint")
- vVarTypes = Utils._AddNumeric(Array(vbEmpty, vbNull, vbDate, vbString, vbBoolean, vbObject, vbVariant))
+ vVarTypes = Utils._AddNumeric(Array(vbEmpty, vbNull, vbDate, vbString, vbBoolean, vbObject, vbVariant, vbByte, 8192 + vbByte))
If UBound(pvArgs) >= 0 Then
For i = 0 To UBound(pvArgs)
diff --git a/wizards/source/access2base/DataDef.xba b/wizards/source/access2base/DataDef.xba
index e151b28..a283264 100644
--- a/wizards/source/access2base/DataDef.xba
+++ b/wizards/source/access2base/DataDef.xba
@@ -19,6 +19,9 @@ Private _Name As String
Private _ParentDatabase As Object
Private _ReadOnly As Boolean
Private Table As Object ' com.sun.star.sdb.dbaccess.ODBTable
+Private CatalogName As String
+Private SchemaName As String
+Private TableName As String
Private Query As Object ' com.sun.star.sdb.dbaccess.OQuery
Private TableDescriptor As Object ' com.sun.star.sdb.dbaccess.ODBTable
Private TableFieldsCount As Integer
@@ -33,6 +36,9 @@ Private Sub Class_Initialize()
Set _ParentDatabase = Nothing
_ReadOnly = False
Set Table = Nothing
+ CatalogName = ""
+ SchemaName = ""
+ TableName = ""
Set Query = Nothing
Set TableDescriptor = Nothing
TableFieldsCount = 0
@@ -151,6 +157,9 @@ Const cstMaxKeyLength = 30
.Precision = Int(pvSize)
If pvType = dbNumeric Or pvType = dbDecimal Or pvType = dbCurrency Then .Scale = Int(pvSize * 10) - Int(pvSize) * 10
.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
+ If Utils._hasUNOProperty(oNewField.Column, "CatalogName") Then .CatalogName = CatalogName
+ If Utils._hasUNOProperty(oNewField.Column, "SchemaName") Then .SchemaName = SchemaName
+ If Utils._hasUNOProperty(oNewField.Column, "TableName") Then .TableName = TableName
If Not IsNull(TableDescriptor) Then TableFieldsCount = TableFieldsCount + 1
If pvAttributes = dbAutoIncrField Then
If Not IsNull(Table) Then Goto Error_Sequence ' Do not accept adding an AutoValue field when table exists
@@ -158,9 +167,14 @@ Const cstMaxKeyLength = 30
Set oPrimaryKey = oKeys.createDataDescriptor()
Set oColumn = oPrimaryKey.Columns.createDataDescriptor()
oColumn.Name = pvFieldName
+ oColumn.CatalogName = CatalogName
+ oColumn.SchemaName = SchemaName
+ oColumn.TableName = TableName
oColumn.IsAutoIncrement = True
+ oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oPrimaryKey.Columns.appendByDescriptor(oColumn)
- oPrimaryKey.Name = Left("PK_" & Join(Split(oNewField._ParentName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength)
+ oPrimaryKey.Name = Left("PK_" & Join(Split(TableName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength)
+ oPrimaryKey.Type = com.sun.star.sdbcx.KeyType.PRIMARY
oKeys.appendByDescriptor(oPrimaryKey)
.IsAutoIncrement = True
.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
@@ -380,6 +394,7 @@ Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As
._PassThrough = bPassThrough
._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
Set ._ParentDatabase = _ParentDatabase
+ Set ._This = oObject
Call ._Initialize()
End With
With _ParentDatabase
diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba
index b54915f..84f1112 100644
--- a/wizards/source/access2base/Database.xba
+++ b/wizards/source/access2base/Database.xba
@@ -197,6 +197,7 @@ Const cstThisSub = "Database.CreateTableDef"
Dim oTable As Object, oTables As Object, sTables() As String
Dim i As Integer, sTableName As String, oNewTable As Object
+Dim vNameComponents() As Variant, iNames As Integer
If _ErrorHandler() Then On Local Error Goto Error_Function
@@ -224,9 +225,17 @@ Dim i As Integer, sTableName As String, oNewTable As Object
Set oNewTable = New DataDef
oNewTable._Type = OBJTABLEDEF
oNewTable._Name = pvTableName
+ vNameComponents = Split(pvTableName, ".")
+ iNames = UBound(vNameComponents)
+ If iNames >= 2 Then oNewtable.CatalogName = vNameComponents(iNames - 2) Else oNewTable.CatalogName = ""
+ If iNames >= 1 Then oNewtable.SchemaName = vNameComponents(iNames - 1) Else oNewTable.SchemaName = ""
+ oNewtable.TableName = vNameComponents(iNames)
Set oNewTable._ParentDatabase = _This
Set oNewTable.TableDescriptor = .createDataDescriptor()
- oNewTable.TableDescriptor.Name = pvTableName
+ oNewTable.TableDescriptor.CatalogName = oNewTable.CatalogName
+ oNewTable.TableDescriptor.SchemaName = oNewTable.SchemaName
+ oNewTable.TableDescriptor.Name = oNewTable.TableName
+ oNewTable.TableDescriptor.Type = "TABLE"
End With
Set CreateTabledef = oNewTable
@@ -503,6 +512,7 @@ Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Obje
._ForwardOnly = ( pvType = dbOpenForwardOnly )
._PassThrough = ( pvOptions = dbSQLPassThrough )
._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
+ Set ._This = oObject
Set ._ParentDatabase = _This
Call ._Initialize()
RecordsetMax = RecordsetMax + 1
@@ -876,8 +886,9 @@ Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCh
' Collect all tables in the database
' pbCheck unpublished
+Const cstThisSub = "Database.TableDefs"
If _ErrorHandler() Then On Local Error Goto Error_Function
- Utils._SetCalledSub("Database.TableDefs")
+ Utils._SetCalledSub(cstThisSub)
If IsMissing(pbCheck) Then pbCheck = False
Dim sObjects() As String, sObjectName As String, oObject As Object
@@ -915,19 +926,24 @@ Dim i As Integer, bFound As Boolean, oTables As Object
End Select
Set oObject = New DataDef
- oObject._Type = OBJTABLEDEF
- oObject._Name = sObjectName
- Set oObject._ParentDatabase = _This
- oObject._ReadOnly = _ReadOnly
- Set oObject.Table = oTables.getByName(sObjectName)
+ With oObject
+ ._Type = OBJTABLEDEF
+ ._Name = sObjectName
+ Set ._ParentDatabase = _This
+ ._ReadOnly = _ReadOnly
+ Set .Table = oTables.getByName(sObjectName)
+ .CatalogName = .Table.CatalogName
+ .SchemaName = .Table.SchemaName
+ .TableName = .Table.Name
+ End With
Exit_Function:
Set TableDefs = oObject
Set oObject = Nothing
- Utils._ResetCalledSub("Database.TableDefs")
+ Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
- TraceError(TRACEABORT, Err, "Database.TableDefs", Erl)
+ TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_NotFound:
If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex))
diff --git a/wizards/source/access2base/Field.xba b/wizards/source/access2base/Field.xba
index 791e3ca..cd8b930 100644
--- a/wizards/source/access2base/Field.xba
+++ b/wizards/source/access2base/Field.xba
@@ -19,6 +19,7 @@ Private _Name As String
Private _ParentName As String
Private _ParentType As String
Private _ParentDatabase As Object
+Private _ParentRecordset As Object
Private Column As Object ' com.sun.star.sdb.OTableColumnWrapper
' or org.openoffice.comp.dbaccess.OQueryColumn
' or com.sun.star.sdb.ODataColumn
@@ -129,6 +130,119 @@ 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
+ 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
+
+ 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(1, pvBytes))
+ Goto Exit_Function
+ End If
+
+ bNullable = ( Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE )
+ bNull = False
+ GetChunk = Null
+ 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
+ End With
+ If bNullable Then bNull = Column.wasNull()
+ If Not bNull Then
+ If pvOffset > 0 Then oValue.skipBytes(pvOffset)
+ oValue.readBytes(vValue, pvBytes)
+ GetChunk = vValue
+ End If
+ oValue.closeInput()
+
+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
@@ -284,6 +398,8 @@ Dim cstThisSub As String
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
+Const cstMaxBinlength = 2 * 65535
+
_PropertyGet = vEMPTY
Select Case UCase(psProperty)
@@ -292,7 +408,7 @@ Const cstMaxTextLength = 65535
Case UCase("DbType")
With com.sun.star.sdbc.DataType
Select Case Column.Type
- Case .BIT : _PropertyGet = dbUndefined
+ Case .BIT : _PropertyGet = dbBoolean
Case .TINYINT : _PropertyGet = dbInteger
Case .SMALLINT : _PropertyGet = dbLong
Case .INTEGER : _PropertyGet = dbLong
@@ -302,8 +418,8 @@ Const cstMaxTextLength = 65535
Case .DOUBLE : _PropertyGet = dbDouble
Case .NUMERIC : _PropertyGet = dbNumeric
Case .DECIMAL : _PropertyGet = dbDecimal
- Case .CHAR : _PropertyGet = dbText
- Case .VARCHAR : _PropertyGet = dbChar
+ Case .CHAR : _PropertyGet = dbChar
+ Case .VARCHAR : _PropertyGet = dbText
Case .LONGVARCHAR : _PropertyGet = dbMemo
Case .CLOB : _PropertyGet = dbMemo
Case .DATE : _PropertyGet = dbDate
@@ -351,7 +467,7 @@ Const cstMaxTextLength = 65535
Case Else
_PropertyGet = ""
End Select
- Case UCase("FieldSize") ' Probably physical size = 2 * unicode string length
+ Case UCase("FieldSize")
With com.sun.star.sdbc.DataType
Select Case Column.Type
Case .VARCHAR, .LONGVARCHAR, .CLOB
@@ -380,7 +496,7 @@ Const cstMaxTextLength = 65535
Case UCase("Size")
With com.sun.star.sdbc.DataType
Select Case Column.Type
- Case .LONGVARCHAR, .LONGVARBINARY
+ 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
@@ -426,7 +542,7 @@ Const cstMaxTextLength = 65535
End If
Case .CHAR : vValue = Column.getString()
Case .VARCHAR : vValue = Column.getString() ' vbString
- Case .LONGVARCHAR
+ Case .LONGVARCHAR, .CLOB
Set oValue = Column.getCharacterStream()
If bNullable Then bNull = Column.wasNull()
If Not bNull Then
@@ -447,21 +563,22 @@ Const cstMaxTextLength = 65535
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
+ Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
Set oValue = Column.getBinaryStream()
If bNullable Then bNull = Column.wasNull()
- If Not bNull Then vValue = CLng(oValue.getLength()) ' vbLong => equivalent to FieldSize
+ 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 .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()
+ If Column.wasNull() Then vValue = Null 'getXXX must precede wasNull()
End If
End With
_PropertyGet = vValue
@@ -477,7 +594,7 @@ Trace_Error:
_PropertyGet = vEMPTY
Goto Exit_Function
Trace_Length:
- TraceError(TRACEFATAL, ERRMEMOLENGTH, Utils._CalledSub(), 0, , lSize)
+ TraceError(TRACEFATAL, ERROVERFLOW, Utils._CalledSub(), 0, , Array(lSize, "GetChunk"))
_PropertyGet = vEMPTY
Goto Exit_Function
Error_Function:
@@ -564,7 +681,7 @@ Dim oParent As Object
Else
Column.updateString(CStr(pvValue))
End If
- Case .CHAR, .VARCHAR, .LONGVARCHAR
+ Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
Column.updateString(pvValue) ' vbString
Case .DATE
@@ -599,9 +716,11 @@ Dim oParent As Object
'.HundredthSeconds = 0
End With
Column.updateTimestamp(vTemp)
-' Case .BINARY, .VARBINARY, .LONGVARBINARY
-' Case .BLOB
-' Case .CLOB
+ 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
diff --git a/wizards/source/access2base/L10N.xba b/wizards/source/access2base/L10N.xba
index 661e286..2dbbdfc 100644
--- a/wizards/source/access2base/L10N.xba
+++ b/wizards/source/access2base/L10N.xba
@@ -65,7 +65,7 @@ Dim sLocal As String
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejected in a forward-only or not bookmarkable recordset"
Case "ERR" & ERRFIELDNULL : sLocal = "Field is null or empty. Action rejected"
Case "ERR" & ERRFILEACCESS : sLocal = "File access error on file '%0'"
- Case "ERR" & ERRMEMOLENGTH : sLocal = "Field length (%0) exceeds maximum length. Use WriteAllText instead"
+ Case "ERR" & ERROVERFLOW : sLocal = "Field length (%0) exceeds maximum length. Use the '%1' method instead"
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "Query '%0' is not an action query"
Case "ERR" & ERRNOTUPDATABLE : sLocal = "Database, recordset or field is read only"
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Recordset update sequence error"
@@ -164,7 +164,7 @@ Dim sLocal As String
Case "ERR" & ERRMETHOD : sLocal = "La méthode '%0' n'est pas applicable dans ce contexte"
Case "ERR" & ERRPROPERTYINIT : sLocal = "Propriété '%0' applicable mais non initialisée"
Case "ERR" & ERRFILENOTCREATED : sLocal = "Erreur de création du fichier '%0'"
- Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialogue '%0' introuvable dans les libraries chargées actuellement"
+ Case "ERR" & ERRDIALOGNOTFOUND : sLocal = "Dialogue '%0' introuvable dans les librairies chargées actuellement"
Case "ERR" & ERRDIALOGUNDEFINED : sLocal = "Boîte de dialogue inconnue"
Case "ERR" & ERRDIALOGSTARTED : sLocal = "Dialogue déjà initialisé précédemment"
Case "ERR" & ERRDIALOGNOTSTARTED : sLocal = "Dialogue '%0' non initialisé"
@@ -174,7 +174,7 @@ Dim sLocal As String
Case "ERR" & ERRRECORDSETFORWARD : sLocal = "Action rejetée car recordset lisible seulement vers l'avant ou n'acceptant pas de signets"
Case "ERR" & ERRFIELDNULL : sLocal = "Champ nul ou vide. Action rejetée"
Case "ERR" & ERRFILEACCESS : sLocal = "Erreur d'accès au fichier '%0'"
- Case "ERR" & ERRMEMOLENGTH : sLocal = "La longueur du champ (%0) dépasse la taille maximale autorisée.. Remplacer par WriteAllText"
+ Case "ERR" & ERROVERFLOW : sLocal = "La longueur du champ (%0) dépasse la taille maximale autorisée. Utiliser de préférence la méthode '%1'"
Case "ERR" & ERRNOTACTIONQUERY : sLocal = "La requête '%0' n'est pas une requête d'action"
Case "ERR" & ERRNOTUPDATABLE : sLocal = "La banque de données, le recordset ou le champ sont en lecture seulement"
Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Erreur de séquence lors de la mise à jour d'un Recordset"
@@ -297,4 +297,4 @@ Dim oLocale as Object
End Function ' GetLocale V0.8.9
-</script:module>
+</script:module>
\ No newline at end of file
diff --git a/wizards/source/access2base/Recordset.xba b/wizards/source/access2base/Recordset.xba
index 8638e0d..698c6e4 100644
--- a/wizards/source/access2base/Recordset.xba
+++ b/wizards/source/access2base/Recordset.xba
@@ -16,6 +16,7 @@ REM ----------------------------------------------------------------------------
Private _Type As String ' Must be RECORDSET
Private _Name As String ' Unique, generated
+Private _This As Object
Private _ParentName As String
Private _ParentType As String
Private _ParentDatabase As Object
@@ -32,14 +33,24 @@ Private _EditMode As Integer ' dbEditxxx constants
Private _BookmarkBeforeNew As Variant
Private _BookmarkLastModified As Variant
Private _IsClone As Boolean
+Private _ManageChunks As Variant ' Array of ChunkDescriptors
Private RowSet As Object ' com.sun.star.comp.dba.ORowSet
+Type ChunkDescriptor
+ ChunksRequested As Boolean
+ FieldName As String
+ ChunkType As Integer ' vbString or vbByte
+ FileName As String
+ FileHandler As Object
+End Type
+
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJRECORDSET
_Name = ""
+ Set _This = Nothing
_ParentName = ""
Set _ParentDatabase = Nothing
_ParentType = ""
@@ -56,6 +67,7 @@ Private Sub Class_Initialize()
_BookmarkBeforeNew = Null
_BookmarkLastModified = Null
_IsClone = False
+ Set _ManageChunks = Array()
Set RowSet = Nothing
End Sub ' Constructor
@@ -296,6 +308,7 @@ Const cstThisSub = "Recordset.CancelUpdate"
Select Case _EditMode
Case dbEditNone
Case dbEditAdd
+ _AppendChunkClose(True)
If Not IsNull(_BookmarkBeforeNew) Then
Select Case _BookmarkBeforeNew
Case "_BOF_" : .beforeFirst()
@@ -305,6 +318,7 @@ Const cstThisSub = "Recordset.CancelUpdate"
End If
Case dbEditInProgress
.cancelRowUpdates()
+ _AppendChunkClose(True)
End Select
End With
@@ -507,6 +521,7 @@ Dim i As Integer, bFound As Boolean, oFields As Object
oObject._ParentName = _Name
oObject._ParentType = _Type
Set oObject._ParentDatabase = _ParentDatabase
+ Set oObject._ParentRecordset = _This
Exit_Function:
Set Fields = oObject
@@ -673,6 +688,7 @@ Dim oObject As Object
._ParentName = _Name
._ParentType = _Type
Set ._ParentDatabase = _ParentDatabase
+ Set ._This = oObject
._ForwardOnly = ( pvType = dbOpenForwardOnly )
._PassThrough = ( pvOptions = dbSQLPassThrough )
._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
@@ -752,6 +768,7 @@ Const cstThisSub = "Recordset.Update"
Case dbEditNone
Goto Trace_Error_Update
Case dbEditAdd
+ _AppendChunkClose(False)
If .IsNew And .IsModified Then .insertRow()
_BookmarkLastModified = .getBookmark()
If Not IsNull(_BookmarkBeforeNew) Then
@@ -762,6 +779,7 @@ Const cstThisSub = "Recordset.Update"
End Select
End If
Case dbEditInProgress
+ _AppendChunkClose(False)
If .IsModified Then
.updateRow()
_BookmarkLastModified = .getBookmark()
@@ -793,6 +811,118 @@ REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _AppendChunk(ByVal psFieldName As String, ByRef pvChunk As Variant, piChunkType) As Boolean
+' Write chunk at the end of the file dedicated to the given field
+
+ If _ErrorHandler() Then On Local Error GoTo Error_Function
+Dim oFileAccess As Object
+Dim i As Integer, oChunk As Object, iChunk As Integer, sRandom As String
+
+ ' Do nothing if chunk meaningless
+ _AppendChunk = False
+ If IsNull(pvChunk) Then GoTo Exit_Function
+ If IsArray(pvChunk) Then
+ If UBound(pvChunk) < LBound(pvChunk) Then GoTo Exit_Function ' Empty array
+ End If
+
+ ' Find or create relevant chunk entry
+ iChunk = -1
+ For i = 0 To UBound(_ManageChunks)
+ Set oChunk = _ManageChunks(i)
+ If oChunk.FieldName = psFieldName Then
+ iChunk = i
+ Exit For
+ End If
+ Next i
+ If iChunk = -1 Then
+ _AppendChunkInit(psFieldName)
+ iChunk = UBound(_ManageChunks)
+ End If
+
+ Set oChunk = _ManageChunks(iChunk)
+ With oChunk
+ If Not .ChunksRequested Then ' First chunk
+ .ChunksRequested = True
+ .ChunkType = piChunkType
+ sRandom = Right("000000" & Int(999999 * Rnd), 6)
+ .FileName = DoCmd._getTempDirectoryURL() & "/" & "A2B_TEMP_" & _Name & "_" & sRandom
+ Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
+ .FileHandler = oFileAccess.openFileWrite(.FileName)
+ End If
+ .FileHandler.writeBytes(pvChunk)
+ End With
+ _AppendChunk = True
+
+Exit_Function:
+ Exit Function
+Error_Function:
+ TraceError(TRACEABORT, Err, "Recordset._AppendChunk", Erl)
+ GoTo Exit_Function
+End Function ' AppendChunk V1.5.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _AppendChunkClose(ByVal pbCancel As Boolean) As Boolean
+' Stores file content to database field(s)
+' Called from Update() [pbCancel = False] or CancelUpdate() [pbCancel = True]
+
+ If _ErrorHandler() Then On Local Error GoTo Error_Function
+Dim oFileAccess As Object, oStream As Object, lFileLength As Long, oField As Object
+Dim i As Integer, oChunk As Object
+
+ _AppendChunkClose = False
+ For i = 0 To UBound(_ManageChunks)
+ Set oChunk = _ManageChunks(i)
+ With oChunk
+ If Not .ChunksRequested Then GoTo Exit_Function
+ If IsNull(.FileHandler) Then GoTo Exit_Function
+ .Filehandler.closeOutput
+ Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
+ ' Copy file to field
+ If Not pbCancel Then
+ Set oStream = oFileAccess.openFileRead(.FileName)
+ lFileLength = oStream.getLength()
+ If lFileLength > 0 Then
+ Set oField = RowSet.getColumns.getByName(.FieldName)
+ Select Case .ChunkType
+ Case vbByte
+ oField.updateBinaryStream(oStream, lFileLength)
+' Case vbString ' DOES NOT WORK FOR CHARACTER TYPES
+' oField.updateCharacterStream(oStream, lFileLength)
+ End Select
+ End If
+ oStream.closeInput()
+ End If
+ If oFileAccess.exists(.FileName) Then oFileAccess.kill(.FileName)
+ End With
+ Next i
+ Set _ManageChunks = Array()
+ _AppendChunkClose = True
+
+Exit_Function:
+ Exit Function
+Error_Function:
+ TraceError(TRACEABORT, Err, "Recordset._AppendChunkClose", Erl)
+ GoTo Exit_Function
+End Function ' AppendChunkClose V1.5.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _AppendChunkInit(psFieldName As String) As Boolean
+' Initialize chunks manager
+
+Dim iSize As Integer
+ iSize = UBound(_ManageChunks) + 1
+ ReDim Preserve _ManageChunks(0 To iSize)
+ Set _ManageChunks(iSize) = New ChunkDescriptor
+ With _ManageChunks(iSize)
+ .ChunksRequested = False
+ .FieldName = psFieldName
+ .FileName = ""
+ Set .FileHandler = Nothing
+ End With
+
+End Function ' AppendChunkInit V1.5.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _Initialize(ByVal Optional pvFilter As Variant, Optional poRowSet As Object)
' Initialize new recordset
diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba
index dd639d5..cd06457 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -126,13 +126,23 @@ Const cstObject = "[com.sun.star.script.NativeObjectWrapper]"
End Function ' CheckArgument V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
-Public Function _CStr(pvArg As Variant, ByVal Optional pbShort As Boolean) As String
+Public Function _CStr(ByVal pvArg As Variant, ByVal Optional pbShort As Boolean) As String
' Convert pvArg into a readable string (truncated if too long and pbShort = True or missing)
+' pvArg may be a byte-array. Other arrays are rejected
-Dim sArg As String, sObject As String, oArg As Object, sLength As String
+Dim sArg As String, sObject As String, oArg As Object, sLength As String, i As Long, iMax As Long
Const cstLength = 50
+Const cstByteLength = 25
If IsArray(pvArg) Then
- sArg = "[ARRAY]"
+ If VarType(pvArg) = vbByte Or VarType(pvArg) - 8192 = vbByte Then
+ sArg = ""
+ If pbShort And UBound(pvArg) > cstByteLength Then iMax = cstByteLength Else iMax = UBound(pvArg)
+ For i = 0 To iMax
+ sArg = sArg & Right("00" & Hex(pvArg(i)), 2)
+ Next i
+ Else
+ sArg = "[ARRAY]"
+ End If
Else
Select Case VarType(pvArg)
Case vbEmpty : sArg = "[EMPTY]"
@@ -143,7 +153,8 @@ Const cstLength = 50
Else
sObject = Utils._ImplementationName(pvArg)
If Utils._IsPseudo(pvArg, Array(OBJDATABASE, OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _
- , OBJEVENT, OBJFIELD, OBJTABLEDEF, OBJQUERYDEF, OBJRECORDSET _
+ , OBJEVENT, OBJFIELD, OBJTABLEDEF, OBJQUERYDEF, OBJRECORDSET, OBJTEMPVAR, OBJCOMMANDBAR, OBJCOMMANDBARCONTROL _
+ , OBJDIALOG _
)) Then
Set oArg = pvArg ' To avoid "Object variable not set" error message
sArg = "[" & oArg._Type & "] " & oArg._Name
@@ -156,6 +167,7 @@ Const cstLength = 50
Case vbVariant : sArg = "[VARIANT]"
Case vbString : sArg = pvArg
Case vbBoolean : sArg = Iif(pvArg, "TRUE", "FALSE")
+ Case vbByte : sArg = Right("00" & Hex(pvArg), 2)
Case Else : sArg = CStr(pvArg)
End Select
End If
@@ -597,13 +609,13 @@ Private Function _PercentEncode(ByVal psChar As String) As String
Dim lChar As Long, sByte1 As String, sByte2 As String, sByte3 As String
lChar = Asc(psChar)
-
+
Select Case lChar
Case 48 To 57, 65 To 90, 97 To 122 ' 0-9, A-Z, a-z
_PercentEncode = psChar
Case Asc("-"), Asc("."), Asc("_"), Asc("~")
_PercentEncode = psChar
- Case Asc("!"), Asc("$"), Asc("&"), Asc("'"), Asc("("), Asc(")"), Asc("*"), Asc("+"), Asc(","), Asc(";"), Asc("=") ' Reserved characters used as delimiters in query strings
+ Case Asc("!"), Asc("$"), Asc("&"), Asc("'"), Asc("("), Asc(")"), Asc("*"), Asc("+"), Asc(","), Asc(";"), Asc("=") ' Reserved characters used as delimitors in query strings
_PercentEncode = psChar
Case Asc(" "), Asc("%")
_PercentEncode = "%" & Right("00" & Hex(lChar), 2)
@@ -839,4 +851,4 @@ Private Function _UTF8Encode(ByVal psChar As String) As String
End Function ' _UTF8Encode V1.4.0
-</script:module>
+</script:module>
\ No newline at end of file
diff --git a/wizards/source/access2base/acConstants.xba b/wizards/source/access2base/acConstants.xba
index 5c390cb..959a71b 100644
--- a/wizards/source/access2base/acConstants.xba
+++ b/wizards/source/access2base/acConstants.xba
@@ -8,7 +8,7 @@ REM ============================================================================
Option Explicit
REM Access2Base -----------------------------------------------------
-Global Const Access2Base_Version = "1.4.0"
+Global Const Access2Base_Version = "1.5.0"
REM AcCloseSave
REM -----------------------------------------------------------------
More information about the Libreoffice-commits
mailing list