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 <[email protected]> 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 -----------------------------------------------------------------
_______________________________________________ Libreoffice-commits mailing list [email protected] http://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
