wizards/source/access2base/Application.xba | 22 ++
wizards/source/access2base/Database.xba | 127 ++++++++++++++
wizards/source/access2base/DoCmd.xba | 254 ++++++++++++++++++++++-------
wizards/source/access2base/Field.xba | 2
wizards/source/access2base/L10N.xba | 4
wizards/source/access2base/Recordset.xba | 5
wizards/source/access2base/Utils.xba | 204 ++++++++++++++++++-----
wizards/source/access2base/_License.xba | 2
wizards/source/access2base/acConstants.xba | 3
9 files changed, 518 insertions(+), 105 deletions(-)
New commits:
commit 3cac16941b775e02159af75d9b390b7dcc08d7ec
Author: Jean-Pierre Ledure <j...@ledure.be>
Date: Thu Oct 13 16:54:15 2016 +0200
Access2Base - CopyObject applied on tables belonging to different databases
So far, only tables belonging to the SAME database could be copied.
Copying tables between databases from different sources (HSQLDB 1.8/2.3,
MySQL, PostGres, Sqlite)
is admitted.
Field type conversions are in this case based on empiric rules.
A case study based on getMetadatInfo() is available on request.
Change-Id: Iae4ea7c4df4799cde3c8f973746513bad56246d8
diff --git a/wizards/source/access2base/Application.xba
b/wizards/source/access2base/Application.xba
index 95f81df..31e0340 100644
--- a/wizards/source/access2base/Application.xba
+++ b/wizards/source/access2base/Application.xba
@@ -72,6 +72,8 @@ Global Const ERRTABLECREATION = 1551
Global Const ERRFIELDCREATION = 1552
Global Const ERRSUBFORMNOTFOUND = 1553
Global Const ERRWINDOW = 1554
+Global Const ERRCOMPATIBILITY = 1555
+Global Const ERRPRECISION = 1556
REM
-----------------------------------------------------------------------------------------------------------------------
Global Const DBCONNECTBASE = 1
' Connection from Base document (OpenConnection)
@@ -79,6 +81,17 @@ Global Const DBCONNECTFORM = 2
' Connection from a database-aware form
Global Const DBCONNECTANY = 3
' Connection from any document for data access only (OpenDatabase)
REM
-----------------------------------------------------------------------------------------------------------------------
+Global Const DBMS_UNKNOWN = 0
+Global Const DBMS_HSQLDB1 = 1
+Global Const DBMS_HSQLDB2 = 2
+Global Const DBMS_FIREBIRD = 3
+Global Const DBMS_MSACCESS2003 = 4
+Global Const DBMS_MSACCESS2007 = 5
+Global Const DBMS_MYSQL = 6
+Global Const DBMS_POSTGRES = 7
+Global Const DBMS_SQLITE = 8
+
+REM
-----------------------------------------------------------------------------------------------------------------------
Global Const COLLALLDIALOGS = "ALLDIALOGS"
Global Const COLLALLFORMS = "ALLFORMS"
Global Const COLLCOMMANDBARS = "COMMANDBARS"
@@ -1039,7 +1052,12 @@ Const cstThisSub = "OpenConnection"
vDocContainer.DbConnect = DBCONNECTBASE
._DbConnect = DBCONNECTBASE
Set .MetaData = .Connection.MetaData
- ._ReadOnly = .Connection.isReadOnly()
+ ._LoadMetadata()
+ If .MetaData.DatabaseProductName =
"MySQL" Then
+ ._ReadOnly = .MetaData.isReadOnly()
+ Else
+ ._ReadOnly = .Connection.isReadOnly()
' Always True in Mysql ??
+ End If
Set .Document = oComponent
.Title = oComponent.Title
.URL = vDocContainer.URL
@@ -1064,6 +1082,7 @@ Const cstThisSub = "OpenConnection"
Set .Connection =
.Form.ActiveConnection ' Might be Nothing in Windows at AOO/LO
startup (not met in Linux)
If Not IsNull(.Connection) Then
Set .MetaData =
.Connection.MetaData
+ ._LoadMetadata()
._ReadOnly =
.Connection.isReadOnly()
TraceLog(TRACEANY,
.MetaData.getDatabaseProductName() & " " &
.MetaData.getDatabaseProductVersion, False)
End If
@@ -1163,6 +1182,7 @@ Const cstThisSub = "OpenDatabase"
Set odbDatabase.Connection = oBaseSource.getConnection(pvUser,
pvPassword)
If Not IsNull(odbDatabase.Connection) Then
' Null when standalone and target db does not exist
Set odbDatabase.MetaData = odbDatabase.Connection.MetaData
+ odbDatabase._LoadMetadata()
Else
Goto Trace_Error
End If
diff --git a/wizards/source/access2base/Database.xba
b/wizards/source/access2base/Database.xba
index d022d4c..a68c64e 100644
--- a/wizards/source/access2base/Database.xba
+++ b/wizards/source/access2base/Database.xba
@@ -23,6 +23,13 @@ Private Connection As
Object '
com.sun.star.sdbc.drivers.OConnectionW
Private URL As String
Private _ReadOnly As Boolean
Private MetaData As Object
' interface XDatabaseMetaData
+Private _RDBMS As Integer
' DBMS constants
+Private _ColumnTypes() As Variant
' Part of Metadata.GetTypeInfo()
+Private _ColumnTypeNames() As Variant
+Private _ColumnPrecisions() As Variant
+Private _ColumnTypesReference() As Variant
+Private _ColumnTypesAlias() As Variant
' To what should a field whose origin is another DBMS be converted ? See
DataTypes By RDBMS.ods
+Private _BinaryStream As Boolean
' False = binary fields must NOT be streamed f.i. via ReadAllBytes or
WriteAllBytes
Private Form As Object
' com.sun.star.form.XForm
Private FormName As String
Private RecordsetMax As Integer
@@ -41,6 +48,13 @@ Private Sub Class_Initialize()
URL = ""
_ReadOnly = False
Set MetaData = Nothing
+ _RDBMS = DBMS_UNKNOWN
+ _ColumnTypes = Array()
+ _ColumnTypeNames = Array()
+ _ColumnPrecisions = Array()
+ _ColumnTypesReference = Array()
+ _ColumnTypesAlias() = Array()
+ _BinaryStream = False
Set Form = Nothing
FormName = ""
RecordsetMax = 0
@@ -1061,6 +1075,119 @@ Error_Function: ' Item by key aborted
End Function ' _hasRecordset V0.9.5
REM
-----------------------------------------------------------------------------------------------------------------------
+Private Sub _LoadMetadata()
+' Load essentially getTypeInfo() results from Metadata
+
+Dim sProduct As String
+Dim iInfo As Integer, oTypeInfo As Object, sName As String, lType As Integer
+
+Const cstMaxInfo = 40
+ ReDim _ColumnTypes(0 To cstMaxInfo)
+ ReDim _ColumnTypeNames(0 To cstMaxInfo)
+ ReDim _ColumnPrecisions(0 To cstMaxInfo)
+Const cstHSQLDB1 = "HSQL Database Engine 1."
+Const cstHSQLDB2 = "HSQL Database Engine 2."
+Const cstMSAccess2003 = "MS Jet 0"
+Const cstMSAccess2007 = "MS Jet 04."
+Const cstMYSQL = "MySQL"
+Const cstPOSTGRES = "PostgreSQL"
+Const cstSQLITE = "SQLite"
+
+ With com.sun.star.sdbc.DataType
+ _ColumnTypesReference = Array( _
+ .ARRAY _
+ , .BIGINT _
+ , .BINARY _
+ , .BIT _
+ , .BLOB _
+ , .BOOLEAN _
+ , .CHAR _
+ , .CLOB _
+ , .DATE _
+ , .DECIMAL _
+ , .DISTINCT _
+ , .DOUBLE _
+ , .FLOAT _
+ , .INTEGER _
+ , .LONGVARBINARY _
+ , .LONGVARCHAR _
+ , .NUMERIC _
+ , .OBJECT _
+ , .OTHER _
+ , .REAL _
+ , .REF _
+ , .SMALLINT _
+ , .SQLNULL _
+ , .STRUCT _
+ , .TIME _
+ , .TIMESTAMP _
+ , .TINYINT _
+ , .VARBINARY _
+ , .VARCHAR _
+ )
+ End With
+
+ With Metadata
+ sProduct = .getDatabaseProductName() & " " &
.getDatabaseProductVersion
+ Select Case True
+ Case Len(sProduct) > Len(cstHSQLDB1) And
Left(sProduct, Len(cstHSQLDB1)) = cstHSQLDB1
+ _RDBMS = DBMS_HSQLDB1
+ _ColumnTypesAlias = Array(0, -5, -2, 16, -4,
16, 1, -1, 91, 3, 0, 8, 6, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3,
12)
+ _BinaryStream = True
+ Case Len(sProduct) > Len(cstHSQLDB2) And
Left(sProduct, Len(cstHSQLDB2)) = cstHSQLDB2
+ _RDBMS = DBMS_HSQLDB2
+ _ColumnTypesAlias = Array(0, -5, -3, -7, 2004,
16, 1, 2005, 91, 3, 0, 8, 8, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -3,
12)
+ _BinaryStream = True
+ Case Len(sProduct) > Len(cstMSAccess2007) And
Left(sProduct, Len(cstMSAccess2007)) = cstMSAccess2007
+ _RDBMS = DBMS_MSACCESS2007
+ _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16,
12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
+ _BinaryStream = True
+ Case Len(sProduct) > Len(cstMSAccess2003) And
Left(sProduct, Len(cstMSAccess2003)) = cstMSAccess2003
+ _RDBMS = DBMS_MSACCESS2003
+ _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16,
12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
+ _BinaryStream = True
+ Case Len(sProduct) > Len(cstMYSQL) And
Left(sProduct, Len(cstMYSQL)) = cstMYSQL
+ _RDBMS = DBMS_MYSQL
+ _ColumnTypesAlias = Array(0, -5, -2, -7, -4,
-7, 1, -1, 91, 3, 0, 8, 8, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3,
-1)
+ _BinaryStream = False
+ Case Len(sProduct) > Len(cstPOSTGRES) And
Left(sProduct, Len(cstPOSTGRES)) = cstPOSTGRES
+ _RDBMS = DBMS_POSTGRES
+ _ColumnTypesAlias = Array(0, -5, -3, 16, -3,
16, 1, 12, 91, 8, 0, 8, 8, 4, -3, 12, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, 4, -3, 12)
+ _BinaryStream = True
+ Case Len(sProduct) > Len(cstSQLITE) And
Left(sProduct, Len(cstSQLITE)) = cstSQLITE
+ _RDBMS = DBMS_SQLITE
+ _ColumnTypesAlias = Array(0, -5, -4, -7, -4,
-7, 1, -1, 91, 8, 0, 8, 6, 4, -4, -1, 8, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -4,
12)
+ _BinaryStream = True
+ Case Else ' Firebird TODO
+ _RDBMS = DBMS_UNKNOWN
+ _BinaryStream = True
+ End Select
+
+ iInfo = -1
+ Set oTypeInfo = MetaData.getTypeInfo()
+ With oTypeInfo
+ .next()
+ Do While Not .isAfterLast() And iInfo < cstMaxInfo
+ sName = .getString(1)
+ lType = .getLong(2)
+ If _RDBMS = DBMS_POSTGRES And (Left(sName, 1)
<> "_" Or lType <> -1) Then ' Skip
+ Else
+ iInfo = iInfo + 1
+ _ColumnTypeNames(iInfo) = sName
+ _ColumnTypes(iInfo) = lType
+ _ColumnPrecisions(iInfo) = .getLong(3)
+ End If
+ .next()
+ Loop
+ End With
+ ReDim Preserve _ColumnTypes(0 To iInfo)
+ ReDim Preserve _ColumnTypeNames(0 To iInfo)
+ ReDim Preserve _ColumnPrecisions(0 To iInfo)
+ End With
+
+End Sub ' _LoadMetadata V1.6.0
+
+REM
-----------------------------------------------------------------------------------------------------------------------
Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String
' Converts input boolean value to HTML compatible string
diff --git a/wizards/source/access2base/DoCmd.xba
b/wizards/source/access2base/DoCmd.xba
index 1b914a4..f85f3c0 100644
--- a/wizards/source/access2base/DoCmd.xba
+++ b/wizards/source/access2base/DoCmd.xba
@@ -193,7 +193,9 @@ Const cstThisSub = "CopyObject"
CopyObject = False
If IsMissing(pvSourceDatabase) Then pvSourceDatabase = ""
- If Not Utils._CheckArgument(pvSourceDatabase, 1, vbString,
"") Then Goto Exit_Function
+ If VarType(pvSourceDatabase) <> vbString Then
+ If Not Utils._CheckArgument(pvSourceDatabase, 1, OBJDATABASE)
Then Goto Exit_Function
+ End If
If IsMissing(pvNewName) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvNewName, 2, vbString) Then Goto
Exit_Function
If IsMissing(pvSourceType) Then Call _TraceArguments()
@@ -202,21 +204,36 @@ Const cstThisSub = "CopyObject"
If IsMissing(pvSourceName) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvSourceName, 2, vbString) Then Goto
Exit_Function
-Dim oSource As Object, oSourceDatabase As Object, oTarget As Object, oDatabase
As Object
-Dim oSourceTable As Object, oSourceColumns As Object, oSourceCol As Object,
oTargetCol As Object
+Dim oSource As Object, oSourceDatabase As Object, oTarget As Object, oDatabase
As Object, bSameDatabase As Boolean
+Dim oSourceTable As Object, oSourceColumns As Object, oSourceCol As Object,
oTargetCol As Object, iRDBMS As Integer
Dim oSourceKeys As Object, oSourceKey As Object, oTargetKey As Object
Dim i As Integer, j As Integer, sSql As String, vPrimaryKeys() As Variant
Dim vNameComponents() As Variant, iNames As Integer, sSurround As String
+Dim vInputFields() As Variant, vFieldBinary() As Variant, vOutputFields() As
Variant
+Dim oInput as Object, oOutput As Object, iNbFields As Integer, vValue As
Variant
+Dim vBinary As Variant, lInputSize As Long, lOutputSize As Long
+Dim lInputRecs As Long, lInputMax As Long, vField As Variant, bProgressMeter
As Boolean, sFile As String
+
+Const cstMaxBinlength = 2 * 65535
+Const cstChunkSize = 2 * 65535
+Const cstProgressMeterLimit = 100
Set oDatabase = Application._CurrentDb()
- If pvSourceDatabase = "" Then
- Set oSourceDatabase = oDatabase
+ bSameDatabase = False
+ If VarType(pvSourceDatabase) = vbString Then
+ If pvSourceDatabase = "" Then
+ Set oSourceDatabase = oDatabase
+ bSameDatabase = True
+ Else
+ Set oSourceDatabase =
Application.OpenDatabase(ConvertToUrl(pvSourceDatabase), , , True)
+ If IsNull(oSourceDatabase) Then Goto Exit_Function
+ End If
Else
- Set oSourceDatabase =
Application.OpenDatabase(ConvertToUrl(pvSourceDatabase), "",
"", True)
- If IsNull(oSourceDatabase) Then Goto Exit_Function
+ Set oSourceDatabase = pvSourceDatabase
End If
With oDatabase
+ iRDBMS = ._RDBMS
If ._DbConnect <> DBCONNECTBASE Then Goto
Error_NotApplicable
Select Case pvSourceType
@@ -237,7 +254,8 @@ Dim vNameComponents() As Variant, iNames As Integer,
sSurround As String
Set oSource =
oSourceDatabase.TableDefs(pvSourceName, True)
If IsNull(oSource) Then Goto Error_NotFound
Set oTarget = .TableDefs(pvNewName, True)
- If Not IsNull(oTarget) Then
.Connection.getTables.dropByName(oTarget.Name) ' a table
with same name exists already ... drop it
+ ' A table with same name exists already
... drop it
+ If Not IsNull(oTarget) Then
.Connection.getTables.dropByName(oTarget.Name)
' Copy source table columns
Set oSourceTable = oSource.Table
Set oTarget =
.Connection.getTables.createDataDescriptor
@@ -253,18 +271,7 @@ Dim vNameComponents() As Variant, iNames As Integer,
sSurround As String
For i = 0 To oSourceColumns.getCount() - 1
' Append each individual column
to the table descriptor
Set oSourceCol =
oSourceColumns.getByIndex(i)
- oTargetCol.Name = oSourceCol.Name
- oTargetCol.ControlDefault =
oSourceCol.ControlDefault
- oTargetCol.Description =
oSourceCol.Description
- oTargetCol.FormatKey =
oSourceCol.FormatKey
- oTargetCol.HelpText =
oSourceCol.HelpText
- oTargetCol.Hidden = oSourceCol.Hidden
- oTargetCol.IsCurrency =
oSourceCol.IsCurrency
- oTargetCol.IsNullable =
oSourceCol.IsNullable
- oTargetCol.Precision =
oSourceCol.Precision
- oTargetCol.Scale = oSourceCol.Scale
- oTargetCol.Type = oSourceCol.Type
- oTargetCol.TypeName =
oSourceCol.TypeName
+ _ConvertDataDescriptor oSourceCol,
oSourceDatabase._RDBMS, oTargetCol, oDatabase
oTarget.Columns.appendByDescriptor(oTargetCol)
Next i
' Copy keys
@@ -277,29 +284,96 @@ Dim vNameComponents() As Variant, iNames As Integer,
sSurround As String
oTargetKey.Name = oSourceKey.Name
oTargetKey.ReferencedTable =
oSourceKey.ReferencedTable
oTargetKey.Type = oSourceKey.Type
-' If oSourceKey.Type =
com.sun.star.sdbcx.KeyType.PRIMARY Then vPrimaryKeys =
oSourceKey.Columns.getElementNames()
oTargetKey.UpdateRule =
oSourceKey.UpdateRule
Set oTargetCol =
oTargetKey.Columns.createDataDescriptor()
For j = 0 To
oSourceKey.Columns.getCount() - 1
Set oSourceCol =
oSourceKey.Columns.getByIndex(j)
- oTargetCol.Name =
oSourceCol.Name
- oTargetCol.Description =
oSourceCol.Description
- oTargetCol.IsCurrency =
oSourceCol.IsCurrency
- oTargetCol.IsNullable =
oSourceCol.IsNullable
- oTargetCol.Precision =
oSourceCol.Precision
- oTargetCol.Scale =
oSourceCol.Scale
- oTargetCol.Type =
oSourceCol.Type
- oTargetCol.TypeName =
oSourceCol.TypeName
+ _ConvertDataDescriptor
oSourceCol, oSourceDatabase._RDBMS, oTargetCol, oDatabase, True
oTargetKey.Columns.appendByDescriptor(oTargetCol)
Next j
oTarget.Keys.appendByDescriptor(oTargetKey)
Next i
' Duplicate table whole design
.Connection.getTables.appendByDescriptor(oTarget)
+
' Copy data
- sSurround = Utils._Surround(oSource.Name)
- sSql = "INSERT INTO " &
Utils._Surround(pvNewName) & " SELECT " & sSurround &
".* FROM " & sSurround
- DoCmd.RunSQL(sSql, dbSQLPassthrough)
+ Select Case bSameDatabase
+ Case True
+ ' Build SQL statement to copy data
+ sSurround =
Utils._Surround(oSource.Name)
+ sSql = "INSERT INTO "
& Utils._Surround(pvNewName) & " SELECT " & sSurround
& ".* FROM " & sSurround
+ DoCmd.RunSQL(sSql)
+ Case False
+ ' Copy data row by row and field
by field
+ ' As it is slow ... display a
progress meter
+ Set oInput =
oSourceDatabase.OpenRecordset(oSource.Name, , , dbReadOnly)
+ Set oOutput =
.Openrecordset(pvNewName)
+
+ With oInput
+ If Not ( ._BOF And
._EOF ) Then
+ .MoveLast
+ lInputMax =
.RecordCount
+ lInputRecs = 0
+ .MoveFirst
+ bProgressMeter
= ( lInputMax > cstProgressMeterLimit )
+
+ iNbFields =
.Fields().Count - 1
+ vInputFields =
Array()
+ vFieldBinary =
Array()
+ vOutputFields =
Array()
+ ReDim
vInputFields(0 To iNbFields), vFieldBinary(0 To iNbFields), vOutputFields(0 To
iNbFields)
+ For i = 0 To
iNbFields
+ Set
vInputFields(i) = .Fields(i)
+
vFieldBinary(i) = Utils._IsBinaryType(vInputFields(i).Column.Type)
+ Set
vOutputFields(i) = oOutput.Fields(i)
+ Next i
+ Else
+ bProgressMeter
= False
+ End If
+ If bProgressMeter Then
Application.SysCmd acSysCmdInitMeter, pvNewName & " 0 %",
lInputMax
+ Do While Not .EOF()
+
oOutput.RowSet.moveToInsertRow()
+
oOutput._EditMode = dbEditAdd
+ For i = 0 To
iNbFields
+ If
vFieldBinary(i) Then
+
lInputSize = vInputFields(i).FieldSize
+
If lInputSize <= cstMaxBinlength Then
+
vField = Utils._getResultSetColumnValue(.RowSet, i + 1, True)
+
Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField)
+
ElseIf oDatabase._BinaryStream Then
+
' Typically for SQLite where binary fields are limited
+
If lInputSize > vOutputFields(i).Column.Precision Then
+
TraceError(TRACEWARNING, ERRPRECISION, Utils._CalledSub(), 0,
1, Array(vOutputFields(i)._Name, lInputRecs + 1))
+
Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i +
1, Null)
+
Else
+
sFile = Utils._GetRandomFileName("BINARY")
+
vInputFields(i)._WriteAll(sFile, "WriteAllBytes")
+
vOutputFields(i)._ReadAll(sFile, "ReadAllBytes")
+
Kill ConvertToUrl(sFile)
+
End If
+
End If
+ Else
+
vField = Utils._getResultSetColumnValue(.RowSet, i + 1)
+
Utils._updateResultSetColumnValue(iRDBMS, oOutput.RowSet, i + 1, vField)
+ End If
+ Next i
+ If
oOutput.RowSet.IsNew And oOutput.RowSet.IsModified Then
oOutput.RowSet.insertRow()
+
oOutput._EditMode = dbEditNone
+ lInputRecs =
lInputRecs + 1
+ If
bProgressMeter Then
+ If
lInputRecs Mod (lInputMax / 100) = 0 Then _
+
Application.SysCmd acSysCmdUpdateMeter, pvNewName & " " &
CStr(CLng(lInputRecs * 100 / lInputMax)) & "%", lInputRecs
+ End If
+ .MoveNext
+ Loop
+ End With
+
+ oOutput.mClose()
+ Set oOutput = Nothing
+ oInput.mClose()
+ Set oInput = Nothing
+ if bProgressMeter Then
Application.SysCmd acSysCmdClearStatus
+ End Select
Case Else
End Select
@@ -308,10 +382,15 @@ Dim vNameComponents() As Variant, iNames As Integer,
sSurround As String
CopyObject = True
Exit_Function:
- If pvSourceDatabase <> "" Then '
Avoid closing the current database
+ ' Avoid closing the current database or the database object given
as source argument
+ If VarType(pvSourceDatabase) = vbString And Not bSameDatabase Then
If Not IsNull(oSourceDatabase) Then oSourceDatabase.mClose()
End If
- Utils._ResetCalledSub(cstThisSub)
+ Set oSourceDatabase = Nothing
+ If Not IsNull(oOutput) Then oOutput.mClose()
+ Set oOutput = Nothing
+ If Not IsNull(oInput) Then oInput.mClose()
+ Set oInput = Nothing
Set oSourceCol = Nothing
Set oSourceKey = Nothing
Set oSourceKeys = Nothing
@@ -321,6 +400,7 @@ Exit_Function:
Set oTargetCol = Nothing
Set oTargetKey = Nothing
Set oTarget = Nothing
+ Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_NotFound:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, ,
Array(Iif(pvSourceType = acQuery, _GetLabel("QUERY"),
_GetLabel("TABLE")), pvSourceName))
@@ -1803,7 +1883,7 @@ Const cstSemiColon = ";"
pvObjectType = acSendForm
pvObjectName = oWindow._Name
End If
- sDirectory = _getTempDirectoryURL()
+ sDirectory = Utils._getTempDirectoryURL()
If Right(sDirectory, 1) <> "/"
Then sDirectory = sDirectory & "/"
If pvOutputFormat = "" Then
sOutputFormat =
_PromptFormat(Array("PDF", "ODT", "DOC",
"HTML")) ' Prompt user for format
@@ -2000,6 +2080,89 @@ Dim bFound As Boolean
End Function ' _CheckColumnType V0.9.1
REM
-----------------------------------------------------------------------------------------------------------------------
+Sub _ConvertDataDescriptor( ByRef poSource As Object _
+ , ByVal piSourceRDBMS
As Integer _
+ , ByRef poTarget As
Object _
+ , ByRef poDatabase As
Object _
+ , ByVal Optional pbKey
As Boolean _
+ )
+' Convert source column descriptor to target descriptor
+' If RDMSs identical, simply move property by property
+' Otherwise
+' - Use Type conversion tables (cfr. DataTypes By RDBMS.ods case
study)
+' - Select among synonyms the entry with the lowest Precision at
least >= source Precision
+' - Derive TypeName and Precision values
+
+Dim vTypesReference() As Variant, vTypes() As Variant, vTypeNames() As Variant
+Dim i As Integer, iType As Integer, iTypeAlias As Integer
+Dim iNbTypes As Integer, iBestFit As Integer, lFitPrecision As Long,
lPrecision As Long
+
+ On Local Error Goto Error_Sub
+ If IsMissing(pbKey) Then pbKey = False
+
+ poTarget.Name = poSource.Name
+ poTarget.Description = poSource.Description
+ If Not pbKey Then
+ poTarget.ControlDefault = poSource.ControlDefault
+ poTarget.FormatKey = poSource.FormatKey
+ poTarget.HelpText = poSource.HelpText
+ poTarget.Hidden = poSource.Hidden
+ End If
+ poTarget.IsCurrency = poSource.IsCurrency
+ poTarget.IsNullable = poSource.IsNullable
+ poTarget.Scale = poSource.Scale
+
+ If piSourceRDBMS = poDatabase._RDBMS Or poDatabase._RDBMS =
DBMS_UNKNOWN Then
+ poTarget.Type = poSource.Type
+ poTarget.Precision = poSource.Precision
+ poTarget.TypeName = poSource.TypeName
+ Goto Exit_Sub
+ End If
+
+ ' Search DataType compatibility
+ With poDatabase
+ ' Find source datatype entry in Reference array
+ iType = -1
+ For i = 0 To UBound(._ColumnTypesReference)
+ If ._ColumnTypesReference(i) = poSource.Type Then
+ iType = i
+ Exit For
+ End If
+ Next i
+ If iType = -1 Then Goto Error_Compatibility
+ iTypeAlias = ._ColumnTypesAlias(iType)
+ ' Find best choice for the datatype of the target column
+ iNbTypes = UBound(._ColumnTypes)
+ iBestFit = -1
+ lFitPrecision = -2 ' Some POSTGRES
datatypes have a precision of -1
+ For i = 0 To iNbTypes
+ If ._ColumnTypes(i) = iTypeAlias Then ' Minimal
fit = correct datatype
+ lPrecision = ._ColumnPrecisions(i)
+ If iBestFit = -1 _
+ Or (iBestFit > -1 And
poSource.Precision > 0 And lPrecision >= poSource.Precision And
lPrecision < lFitPrecision) _
+ Or (iBestFit > -1 And
poSource.Precision = 0 And lPrecision > lFitPrecision) Then ' First
fit or better fit
+ iBestFit = i
+ lFitPrecision = lPrecision
+ End If
+ End If
+ Next i
+ If iBestFit = -1 Then Goto Error_Compatibility
+ poTarget.Type = iTypeAlias
+ poTarget.Precision = lFitPrecision
+ poTarget.TypeName = ._ColumnTypeNames(iBestFit)
+ End With
+
+Exit_Sub:
+ Exit Sub
+Error_Compatibility:
+ TraceError(TRACEFATAL, ERRCOMPATIBILITY, Utils._CalledSub(), 0, 1,
poSource.Name)
+ Goto Exit_Sub
+Error_Sub:
+ TraceError(TRACEABORT, Err, "_ConvertDataDescriptor", Erl)
+ Goto Exit_Sub
+End Sub ' ConvertDataDescriptor V1.6.0
+
+REM
-----------------------------------------------------------------------------------------------------------------------
Private Function _DatabaseForm(psForm As String, psControl As String)
'Return DatabaseForm element of Form object (based on psForm which is
known as a real form name)
'or of SubForm object (based on psControl which is checked for being a
subform)
@@ -2056,27 +2219,6 @@ Dim sCommand As String
End Sub ' _DispatchCommand V1.3.0
REM
-----------------------------------------------------------------------------------------------------------------------
-Private Function _getTempDirectoryURL() As String
-' Return the temporary directory defined in the OO Options (Paths)
-Dim sDirectory As String, oSettings As Object, oPathSettings As Object
-
- If _ErrorHandler() Then On Local Error Goto Error_Function
-
- _getTempDirectoryURL = ""
- oPathSettings = createUnoService(
"com.sun.star.util.PathSettings" )
- sDirectory = oPathSettings.GetPropertyValue( "Temp" )
-
- _getTempDirectoryURL = sDirectory
-
-Exit_Function:
- Exit Function
-Error_Function:
- TraceError("ERROR", Err, "_getTempDirectoryURL",
Erl)
- _getTempDirectoryURL = ""
- Goto Exit_Function
-End Function ' _getTempDirectoryURL V0.8.5
-
-REM
-----------------------------------------------------------------------------------------------------------------------
Public Function _getUpperShortcut(ByVal psShortcut As String, ByVal
psLastComponent As String) As String
' Return "Forms!myForm" from "Forms!myForm!datField"
and "datField"
diff --git a/wizards/source/access2base/Field.xba
b/wizards/source/access2base/Field.xba
index 5b94ba2..d08bcfb 100644
--- a/wizards/source/access2base/Field.xba
+++ b/wizards/source/access2base/Field.xba
@@ -151,7 +151,7 @@ Dim iChunkType As Integer
Select Case Column.Type ' DOES NOT WORK
FOR CHARACTER TYPES
' Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
' iChunkType = vbString
- Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
+ Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB, .CHAR
' .CHAR added for Sqlite3
iChunkType = vbByte
Case Else
Goto Trace_Error
diff --git a/wizards/source/access2base/L10N.xba
b/wizards/source/access2base/L10N.xba
index 2dbbdfc..db39159 100644
--- a/wizards/source/access2base/L10N.xba
+++ b/wizards/source/access2base/L10N.xba
@@ -78,6 +78,8 @@ Dim sLocal As String
Case "ERR" & ERRFIELDCREATION
: sLocal = "Field '%0' could not be created"
Case "ERR" & ERRSUBFORMNOTFOUND
: sLocal = "Subform '%0' not found in parent form
'%1'"
Case "ERR" & ERRWINDOW
: sLocal = "Current window is not a document"
+ Case "ERR" & ERRCOMPATIBILITY
: sLocal = "Field '%0' could not be converted due
to incompatibility of field types between database systems"
+ Case "ERR" & ERRPRECISION
: sLocal = "Field '%0' could not be loaded in
record #%1 due to capacity shortage"
'----------------------------------------------------------------------------------------------------------------------
Case "OBJECT"
: sLocal = "Object"
Case "TABLE"
: sLocal = "Table"
@@ -187,6 +189,8 @@ Dim sLocal As String
Case "ERR" & ERRFIELDCREATION
: sLocal = "Le champ '%0' n'a pas pu être
créé"
Case "ERR" & ERRSUBFORMNOTFOUND
: sLocal = "Sous-formulaire '%0' non trouvé dans
le formulaire parent '%1'"
Case "ERR" & ERRWINDOW
: sLocal = "La fenêtre courante n'est pas un
document"
+ Case "ERR" & ERRCOMPATIBILITY
: sLocal = "Le champ '%0' n'a pas pu être
converti à cause d'une incompatibilité entre les types de champs
supportés par les systèmes de bases de données respectifs"
+ Case "ERR" & ERRPRECISION
: sLocal = "Le champ '%0' n'a pas pu être
chargé dans l'enregistrement #%1 par manque de capacité"
'----------------------------------------------------------------------------------------------------------------------
Case "OBJECT"
: sLocal = "Objet"
Case "TABLE"
: sLocal = "Table"
diff --git a/wizards/source/access2base/Recordset.xba
b/wizards/source/access2base/Recordset.xba
index 698c6e4..b16b153 100644
--- a/wizards/source/access2base/Recordset.xba
+++ b/wizards/source/access2base/Recordset.xba
@@ -816,7 +816,7 @@ Public Function _AppendChunk(ByVal psFieldName As String,
ByRef pvChunk As Varia
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
+Dim i As Integer, oChunk As Object, iChunk As Integer
' Do nothing if chunk meaningless
_AppendChunk = False
@@ -844,8 +844,7 @@ Dim i As Integer, oChunk As Object, iChunk As Integer,
sRandom As String
If Not .ChunksRequested Then ' First chunk
.ChunksRequested = True
.ChunkType = piChunkType
- sRandom = Right("000000" & Int(999999 *
Rnd), 6)
- .FileName = DoCmd._getTempDirectoryURL() &
"/" & "A2B_TEMP_" & _Name & "_" &
sRandom
+ .FileName = Utils._GetRandomFileName(_Name)
Set oFileAccess =
CreateUnoService("com.sun.star.ucb.SimpleFileAccess")
.FileHandler = oFileAccess.openFileWrite(.FileName)
End If
diff --git a/wizards/source/access2base/Utils.xba
b/wizards/source/access2base/Utils.xba
index ecae60e..a7be0b3 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -38,7 +38,7 @@ Dim i As Integer, vNewList() As Variant, vNumeric() As
Variant, iSize As Integer
vNewList = Array(pvTypes)
End If
- vNumeric = Array(vbInteger, vbLong, vbSingle, vbDouble, vbCurrency,
vbBigint, vbDecimal)
+ vNumeric = Array(vbInteger, vbLong, vbSingle, vbDouble, vbCurrency,
vbBigint, vbDecimal, vbBoolean)
iSize = UBound(vNewlist)
ReDim Preserve vNewList(iSize + UBound(vNumeric) + 1)
@@ -115,7 +115,6 @@ Dim iVarType As Integer
If VarType(pvItem) = vbCurrency Or VarType(pvItem) = vbDecimal Or
VarType(pvItem) = vbBigint Then pvItem = CDbl(pvItem)
Exit_Function:
-Const cstObject = "[com.sun.star.script.NativeObjectWrapper]"
If Not _CheckArgument Then
If IsMissing(pvError) Then pvError = True
If pvError Then
@@ -198,7 +197,7 @@ Dim oPip As Object, sLocation As String
End Function ' ExtensionLocation
REM
-----------------------------------------------------------------------------------------------------------------------
-Private Function _getResultSetColumnValue(poResultSet As Object _
+Private Function _GetResultSetColumnValue(poResultSet As Object _
, ByVal piColIndex As Integer _
, Optional ByVal pbReturnBinary As Boolean _
) As Variant
@@ -207,7 +206,7 @@ REM get the data for the column specified by ColIndex
REM If pbReturnBinary = False (default) then return length of binary field
REM get type name from metadata
-Dim vValue As Variant, sType As String, vDateTime As Variant, oValue As Object
+Dim vValue As Variant, iType As Integer, vDateTime As Variant, oValue As Object
Dim bNullable As Boolean, lSize As Long
Const cstMaxTextLength = 65535
Const cstMaxBinlength = 2 * 65535
@@ -215,15 +214,15 @@ Const cstMaxBinlength = 2 * 65535
On Local Error Goto 0 ' Disable error handler
vValue = Null ' Default value
if error
If IsMissing(pbReturnBinary) Then pbReturnBinary = False
- With poResultSet
- sType = .MetaData.getColumnTypeName(piColIndex)
- bNullable = ( .MetaData.IsNullable(piColIndex) =
com.sun.star.sdbc.ColumnValue.NULLABLE )
- Select Case sType
- Case "ARRAY":
vValue = .getArray(piColIndex)
- Case "BINARY", "VARBINARY",
"LONGVARBINARY", "BLOB"
-
Set oValue = .getBinaryStream(piColIndex)
+ With com.sun.star.sdbc.DataType
+ iType = poResultSet.MetaData.getColumnType(piColIndex)
+ bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) =
com.sun.star.sdbc.ColumnValue.NULLABLE )
+ Select Case iType
+ Case .ARRAY
: vValue = poResultSet.getArray(piColIndex)
+ Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
+
Set oValue = poResultSet.getBinaryStream(piColIndex)
If bNullable Then
-
If Not .wasNull() Then
+
If Not poResultSet.wasNull() Then
If Not _hasUNOMethod(oValue,
"getLength") Then ' When no recordset
lSize = cstMaxBinLength
Else
@@ -233,57 +232,58 @@ Const cstMaxBinlength = 2 * 65535
vValue = Array()
oValue.readBytes(vValue, lSize)
Else ' Return length of field,
not content
+
vValue = lSize
End If
End If
End If
oValue.closeInput()
- Case "BIT", "BOOLEAN":
vValue = .getBoolean(piColIndex)
- Case "BYTE":
vValue = .getByte(piColIndex)
- Case "BYTES":
vValue = .getBytes(piColIndex)
- Case "DATE":
vDateTime = .getDate(piColIndex)
-
If Not .wasNull() Then vValue =
DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day))
- Case "DOUBLE", "REAL":
vValue = .getDouble(piColIndex)
- Case "FLOAT":
vValue = .getFloat(piColIndex)
- Case "INTEGER", "SMALLINT":
vValue = .getInt(piColIndex)
- Case "LONG", "BIGINT":
vValue = .getLong(piColIndex)
- Case "DECIMAL", "NUMERIC":
vValue = .getDouble(piColIndex)
- Case "NULL":
vValue = .getNull(piColIndex)
- Case "OBJECT":
vValue = Null ' .getObject(piColIndex) does
not work that well in Basic ...
- Case "REF":
vValue = .getRef(piColIndex)
- Case "SHORT", "TINYINT":
vValue = .getShort(piColIndex)
- Case "CHAR", "VARCHAR":
vValue = .getString(piColIndex)
- Case "LONGVARCHAR", "CLOB"
-
Set oValue = .getCharacterStream(piColIndex)
+ Case .BIT, .BOOLEAN :
vValue = poResultSet.getBoolean(piColIndex)
+ Case .DATE
: vDateTime = poResultSet.getDate(piColIndex)
+
If Not poResultSet.wasNull() Then vValue =
DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day))
+ Case .DISTINCT, .OBJECT, .OTHER, .STRUCT
+
vValue = Null
+ Case .DOUBLE, .REAL :
vValue = poResultSet.getDouble(piColIndex)
+ Case .FLOAT
: vValue = poResultSet.getFloat(piColIndex)
+ Case .INTEGER, .SMALLINT :
vValue = poResultSet.getInt(piColIndex)
+ Case .BIGINT :
vValue = poResultSet.getLong(piColIndex)
+ Case .DECIMAL, .NUMERIC :
vValue = poResultSet.getDouble(piColIndex)
+ Case .SQLNULL :
vValue = poResultSet.getNull(piColIndex)
+ Case .OBJECT, .OTHER, .STRUCT : vValue
= Null
+ Case .REF
: vValue = poResultSet.getRef(piColIndex)
+ Case .TINYINT :
vValue = poResultSet.getShort(piColIndex)
+ Case .CHAR, .VARCHAR :
vValue = poResultSet.getString(piColIndex)
+ Case .LONGVARCHAR, .CLOB
+
Set oValue = poResultSet.getCharacterStream(piColIndex)
If bNullable Then
-
If Not .wasNull() Then
+
If Not poResultSet.wasNull() Then
If Not _hasUNOMethod(oValue,
"getLength") Then ' When no recordset
lSize = cstMaxTextLength
Else
lSize = CLng(oValue.getLength())
End If
oValue.closeInput()
-
If lSize <= cstMaxBinLength Then
vValue = .getString(piColIndex) Else vValue = ""
+
If lSize <= cstMaxBinLength Then
vValue = poResultSet.getString(piColIndex) Else vValue = ""
End If
Else
oValue.closeInput()
End If
- Case "TIME":
vDateTime = .getTime(piColIndex)
-
If Not .wasNull() Then vValue =
TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)',
vDateTime.HundredthSeconds)
- Case "TIMESTAMP":
vDateTime = .getTimeStamp(piColIndex)
-
If Not .wasNull() Then vValue =
DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _
+ Case .TIME
: vDateTime = poResultSet.getTime(piColIndex)
+
If Not poResultSet.wasNull() Then vValue =
TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)',
vDateTime.HundredthSeconds)
+ Case .TIMESTAMP :
vDateTime = poResultSet.getTimeStamp(piColIndex)
+
If Not poResultSet.wasNull() Then vValue =
DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _
+ TimeSerial(vDateTime.Hours,
vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds)
Case Else
- vValue = .getString(piColIndex)
'GIVE STRING A TRY
+ vValue = poResultSet.getString(piColIndex)
'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 .wasNull() Then vValue = Null
+ If poResultSet.wasNull() Then vValue = Null
End If
End With
- _getResultSetColumnValue = vValue
+ _GetResultSetColumnValue = vValue
-End Function ' getResultSetColumnValue V 1.5.0
+End Function ' GetResultSetColumnValue V 1.5.0
REM
-----------------------------------------------------------------------------------------------------------------------
Public Function _FinalProperty(psShortcut As String) As String
@@ -327,6 +327,16 @@ Dim sProdName as String
End Function ' GetProductName V1.0.0
REM
-----------------------------------------------------------------------------------------------------------------------
+Public Function _GetRandomFileName(ByVal psName As String) As String
+' Return the full name of a random temporary file suffixed by psName
+
+Dim sRandom As String
+ sRandom = Right("000000" & Int(999999 * Rnd), 6)
+ _GetRandomFileName = Utils._getTempDirectoryURL() & "/"
& "A2B_TEMP_" & psName & "_" & sRandom
+
+End Function ' GetRandomFileName
+
+REM
-----------------------------------------------------------------------------------------------------------------------
Public Function _GetRegistryKeyContent(sKeyName as string, Optional bforUpdate
as Boolean) As Variant
'Implement ConfigurationProvider service
'Derived from Tools library
@@ -345,6 +355,27 @@ Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
End Function ' GetRegistryKeyContent V0.8.5
REM
-----------------------------------------------------------------------------------------------------------------------
+Public Function _getTempDirectoryURL() As String
+' Return the temporary directory defined in the OO Options (Paths)
+Dim sDirectory As String, oSettings As Object, oPathSettings As Object
+
+ If _ErrorHandler() Then On Local Error Goto Error_Function
+
+ _getTempDirectoryURL = ""
+ oPathSettings = createUnoService(
"com.sun.star.util.PathSettings" )
+ sDirectory = oPathSettings.GetPropertyValue( "Temp" )
+
+ _getTempDirectoryURL = sDirectory
+
+Exit_Function:
+ Exit Function
+Error_Function:
+ TraceError("ERROR", Err, "_getTempDirectoryURL",
Erl)
+ _getTempDirectoryURL = ""
+ Goto Exit_Function
+End Function ' _getTempDirectoryURL V0.8.5
+
+REM
-----------------------------------------------------------------------------------------------------------------------
Public Function _getUNOTypeName(pvObject As Variant) As String
' Return the symbolic name of the pvObject (UNO-object) type
' Code-snippet from XRAY
@@ -493,6 +524,20 @@ Dim iLength As Integer
End Function
REM
-----------------------------------------------------------------------------------------------------------------------
+Public Function _IsBinaryType(ByVal lType As Long) As Boolean
+
+ With com.sun.star.sdbc.DataType
+ Select Case lType
+ Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
+ _IsBinaryType = True
+ Case Else
+ _IsBinaryType = False
+ End Select
+ End With
+
+End Function ' IsBinaryType V1.6.0
+
+REM
-----------------------------------------------------------------------------------------------------------------------
Public Function _IsPseudo(pvObject As Variant, ByVal pvType As Variant) As
Boolean
' Test pvObject: does it exist ?
' is the _Type item = one of the proposed
pvTypes ?
@@ -542,7 +587,7 @@ Dim oDoc As Object, oForms As Variant
End If
End If
Case OBJDATABASE
- If ._DbConnect = DBCONNECTFORM Then
bPseudoExists = True Else bPseudoExists =
.Document.CurrentController.IsConnected
+ If ._DbConnect = DBCONNECTFORM Then
bPseudoExists = True Else bPseudoExists = Not IsNull(.Connection)
Case OBJDIALOG
If ._Name <> "" Then
' Check validity of dialog name
bPseudoExists = (
_A2B_.hasItem(COLLALLDIALOGS, ._Name) )
@@ -652,7 +697,7 @@ Dim lChar As Long, sByte1 As String, sByte2 As String,
sByte3 As String
_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 delimiter 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)
@@ -831,6 +876,81 @@ Dim sTrim As String, vTrim() As Variant, i As Integer, j
As Integer, iCount As I
End Function ' TrimArray V0.9.0
REM
-----------------------------------------------------------------------------------------------------------------------
+Private Function _UpdateResultSetColumnValue(piRDBMS As Integer _
+
, poResultSet As Object _
+
, ByVal piColIndex As Integer _
+
, ByVal pvValue As Variant _
+
) As Boolean
+REM store the pvValue for the column specified by ColIndex
+REM get type name from metadata
+
+Dim iType As Integer, vDateTime As Variant, oValue As Object
+Dim bNullable As Boolean, lSize As Long, iValueType As Integer, sValueTypeName
As String
+Const cstMaxTextLength = 65535
+Const cstMaxBinlength = 2 * 65535
+
+ On Local Error Goto 0 ' Disable error handler
+ _UpdateResultSetColumnValue = False
+ With com.sun.star.sdbc.DataType
+ iType = poResultSet.MetaData.getColumnType(piColIndex)
+ iValueType = VarType(pvValue)
+ sValueTypeName =
UCase(poResultSet.MetaData.getColumnTypeName(piColIndex))
+ bNullable = ( poResultSet.MetaData.IsNullable(piColIndex) =
com.sun.star.sdbc.ColumnValue.NULLABLE )
+
+ If bNullable And IsNull(pvValue) Then
+ poResultSet.updateNull(piColIndex)
+ Else
+ Select Case iType
+ Case .ARRAY, .DISTINCT, .OBJECT, .OTHER, .REF,
.SQLNULL, .STRUCT
+
poResultSet.updateNull(piColIndex)
+ Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
+
poResultSet.updateBytes(piColIndex, pvValue)
+ Case .BIT, .BOOLEAN
: poResultSet.updateBoolean(piColIndex, pvValue)
+ Case .DATE
: vDateTime =
CreateUnoStruct("com.sun.star.util.Date")
+
vDateTime.Year = Year(pvValue)
+
vDateTime.Month = Month(pvValue)
+
vDateTime.Day = Day(pvValue)
+
poResultSet.updateDate(piColIndex, vDateTime)
+ Case .DECIMAL, .NUMERIC :
poResultSet.updateDouble(piColIndex, pvValue)
+ Case .DOUBLE, .REAL
: poResultSet.updateDouble(piColIndex, pvValue)
+ Case .FLOAT
: poResultSet.updateFloat(piColIndex, pvValue)
+ Case .INTEGER, .SMALLINT :
poResultSet.updateInt(piColIndex, pvValue)
+ Case .BIGINT
: poResultSet.updateLong(piColIndex, pvValue)
+ Case .DECIMAL, .NUMERIC :
poResultSet.updateDouble(piColIndex, pvValue)
+ Case .TINYINT
: poResultSet.updateShort(piColIndex, pvValue)
+ Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
+
If piRDBMS = DBMS_SQLITE And
InStr(sValueTypeName, "BINARY") >0 Then '
Sqlite exception ... !
+
poResultSet.updateBytes(piColIndex,
pvValue)
+
Else
+
poResultSet.updateString(piColIndex,
pvValue)
+
End If
+ Case .TIME
: vDateTime =
CreateUnoStruct("com.sun.star.util.Time")
+
vDateTime.Hours = Hour(pvValue)
+
vDateTime.Minutes = Minute(pvValue)
+
vDateTime.Seconds = Second(pvValue)
+
'vDateTime.HundredthSeconds = 0
+
poResultSet.updateTime(piColIndex, vDateTime)
+ Case .TIMESTAMP
: vDateTime =
CreateUnoStruct("com.sun.star.util.DateTime")
+
vDateTime.Year = Year(pvValue)
+
vDateTime.Month = Month(pvValue)
+
vDateTime.Day = Day(pvValue)
+
vDateTime.Hours = Hour(pvValue)
+
vDateTime.Minutes = Minute(pvValue)
+
vDateTime.Seconds = Second(pvValue)
+
'vDateTime.HundredthSeconds = 0
+
poResultSet.updateTimestamp(piColIndex,
vDateTime)
+ Case Else
+ If bNullable Then
poResultSet.updateNull(piColIndex)
+ End Select
+ End If
+
+ End With
+
+ _UpdateResultSetColumnValue = True
+
+End Function ' UpdateResultSetColumnValue V 1.6.0
+
+REM
-----------------------------------------------------------------------------------------------------------------------
Private Function _URLEncode(ByVal psToEncode As String) As String
' http://www.w3schools.com/tags/ref_urlencode.asp
' http://xkr.us/articles/javascript/encode-compare/
@@ -897,4 +1017,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/_License.xba
b/wizards/source/access2base/_License.xba
index 4fc58ca..7f53269 100644
--- a/wizards/source/access2base/_License.xba
+++ b/wizards/source/access2base/_License.xba
@@ -1,6 +1,6 @@
<?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="_License" script:language="StarBasic">' Copyright
2012-2013 Jean-Pierre LEDURE
+<script:module xmlns:script="http://openoffice.org/2000/script";
script:name="_License" script:language="StarBasic">' Copyright
2012-2017 Jean-Pierre LEDURE
REM
=======================================================================================================================
REM === The Access2Base library is a
part of the LibreOffice project.
===
diff --git a/wizards/source/access2base/acConstants.xba
b/wizards/source/access2base/acConstants.xba
index 959a71b..f804074 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.5.0"
+Global Const Access2Base_Version = "1.6.0"
REM AcCloseSave
REM -----------------------------------------------------------------
@@ -87,6 +87,7 @@ Global Const vbUShort = 18
Global Const vbULong = 19
Global Const vbBigint = 35
Global Const vbDecimal = 37
+Global Const vbArray = 8192
REM MsgBox constants
REM -----------------------------------------------------------------
_______________________________________________
Libreoffice-commits mailing list
libreoffice-comm...@lists.freedesktop.org
https://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
