wizards/source/access2base/Application.xba | 8 +--
wizards/source/access2base/DoCmd.xba | 75 ++++++++++++++++++-----------
wizards/source/access2base/Utils.xba | 15 ++++-
3 files changed, 64 insertions(+), 34 deletions(-)
New commits:
commit fc0f2c5f88544ae2f5ab208efa137747a14da44d
Author: Jean-Pierre Ledure <j...@ledure.be>
Date: Mon May 16 12:40:36 2016 +0200
Access2Base - CopyObject method extended to MySql and Sqlite
Tables must belong to the same database.
INSERT SQL statement syntax extended
Table- and fieldnames correct surrounding
Correction of incident declared in
https://ask.libreoffice.org/en/question/69795/access2base-findrecord-only-for-numbers/
Change-Id: Ice148d872cacfc80df421132020ab1717e7c908c
diff --git a/wizards/source/access2base/Application.xba
b/wizards/source/access2base/Application.xba
index ae7483b..95f81df 100644
--- a/wizards/source/access2base/Application.xba
+++ b/wizards/source/access2base/Application.xba
@@ -1112,7 +1112,7 @@ Public Function OpenDatabase ( _
' Return a database object based on input arguments:
' Call template:
-' Call OpenConnection("... databaseURL ..."[,
"", "", True/False])
+' Call OpenDatabase("... databaseURL ..."[,
"", "", True/False])
' pvDatabaseURL maby be the name of a registered database or the URL of
the targeted .odb file
' Might be called from any AOO/LibO application, independently from
OpenConnection
@@ -1120,7 +1120,10 @@ Dim odbDatabase As Variant, oBaseContext As Object,
sDbNames() As String, oBaseS
Dim i As Integer, bFound As Boolean
Dim sDatabaseURL As String
- If IsEmpty(_A2B_) Then Call Application._RootInit() ' First
use of Access2Base in current AOO/LibO session
+ If IsEmpty(_A2B_) Then ' First
use of Access2Base in current AOO/LibO session
+ Call Application._RootInit()
+ TraceLog(TRACEANY, Utils._GetProductName() & " -
" & Application.ProductCode(), False)
+ End If
Set OpenDatabase = Nothing
If _ErrorHandler() Then On Local Error Goto Error_Function
@@ -1173,7 +1176,6 @@ Const cstThisSub = "OpenDatabase"
Set OpenDatabase = odbDatabase
- TraceLog(TRACEANY, Utils._GetProductName() & " - " &
Application.ProductCode(), False)
TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() &
" " & odbDatabase.MetaData.getDatabaseProductVersion, False)
TraceLog(TRACEANY, UCase(cstThisSub) & " " &
odbDatabase.URL, False)
diff --git a/wizards/source/access2base/DoCmd.xba
b/wizards/source/access2base/DoCmd.xba
index 8fe7ec9..1b914a4 100644
--- a/wizards/source/access2base/DoCmd.xba
+++ b/wizards/source/access2base/DoCmd.xba
@@ -181,7 +181,7 @@ Error_NotApplicable:
End Function ' (m)Close V1.1.0
REM
-----------------------------------------------------------------------------------------------------------------------
-Public Function CopyObject(ByVal Optional pvDestinationDatabase As Variant _
+Public Function CopyObject(ByVal Optional pvSourceDatabase As Variant _
, ByVal Optional
pvNewName As Variant _
, ByVal Optional
pvSourceType As Variant _
, ByVal Optional
pvSourceName As Variant _
@@ -192,8 +192,8 @@ Const cstThisSub = "CopyObject"
Utils._SetCalledSub(cstThisSub)
CopyObject = False
- If IsMissing(pvDestinationDatabase) Then pvDestinationDatabase =
""
- If Not Utils._CheckArgument(pvDestinationDatabase, 1, vbString,
"") Then Goto Exit_Function
+ If IsMissing(pvSourceDatabase) Then pvSourceDatabase = ""
+ If Not Utils._CheckArgument(pvSourceDatabase, 1, vbString,
"") Then Goto Exit_Function
If IsMissing(pvNewName) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvNewName, 2, vbString) Then Goto
Exit_Function
If IsMissing(pvSourceType) Then Call _TraceArguments()
@@ -202,19 +202,26 @@ Const cstThisSub = "CopyObject"
If IsMissing(pvSourceName) Then Call _TraceArguments()
If Not Utils._CheckArgument(pvSourceName, 2, vbString) Then Goto
Exit_Function
-Dim oSource As Object, oTarget As Object, oDatabase As Object
+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 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
Set oDatabase = Application._CurrentDb()
+ If pvSourceDatabase = "" Then
+ Set oSourceDatabase = oDatabase
+ Else
+ Set oSourceDatabase =
Application.OpenDatabase(ConvertToUrl(pvSourceDatabase), "",
"", True)
+ If IsNull(oSourceDatabase) Then Goto Exit_Function
+ End If
With oDatabase
If ._DbConnect <> DBCONNECTBASE Then Goto
Error_NotApplicable
Select Case pvSourceType
Case acQuery
- Set oSource = .QueryDefs(pvSourceName, True)
+ Set oSource =
oSourceDatabase.QueryDefs(pvSourceName, True)
If IsNull(oSource) Then Goto Error_NotFound
Set oTarget = .QueryDefs(pvNewName, True)
If Not IsNull(oTarget) Then
.Connection.getQueries.dropByName(oTarget.Name) ' a query
with same name exists already ... drop it
@@ -227,7 +234,7 @@ Dim i As Integer, j As Integer, sSql As String,
vPrimaryKeys() As Variant
.Document.store()
Case acTable
- Set oSource = .TableDefs(pvSourceName, True)
+ 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
@@ -235,7 +242,11 @@ Dim i As Integer, j As Integer, sSql As String,
vPrimaryKeys() As Variant
Set oSourceTable = oSource.Table
Set oTarget =
.Connection.getTables.createDataDescriptor
oTarget.Description = oSourceTable.Description
- oTarget.Name = pvNewName
+ vNameComponents = Split(pvNewName,
".")
+ iNames = UBound(vNameComponents)
+ If iNames >= 2 Then oTarget.CatalogName =
vNameComponents(iNames - 2) Else oTarget.CatalogName = ""
+ If iNames >= 1 Then oTarget.SchemaName =
vNameComponents(iNames - 1) Else oTarget.SchemaName = ""
+ oTarget.Name = vNameComponents(iNames)
oTarget.Type = oSourceTable.Type
Set oSourceColumns = oSourceTable.Columns
Set oTargetCol =
oTarget.Columns.createDataDescriptor
@@ -286,7 +297,8 @@ Dim i As Integer, j As Integer, sSql As String,
vPrimaryKeys() As Variant
' Duplicate table whole design
.Connection.getTables.appendByDescriptor(oTarget)
' Copy data
- sSql = "INSERT INTO [" &
pvNewName & "] SELECT [" & oSource.Name & "].* FROM
[" & oSource.Name & "]"
+ sSurround = Utils._Surround(oSource.Name)
+ sSql = "INSERT INTO " &
Utils._Surround(pvNewName) & " SELECT " & sSurround &
".* FROM " & sSurround
DoCmd.RunSQL(sSql, dbSQLPassthrough)
Case Else
@@ -296,6 +308,9 @@ Dim i As Integer, j As Integer, sSql As String,
vPrimaryKeys() As Variant
CopyObject = True
Exit_Function:
+ If pvSourceDatabase <> "" Then '
Avoid closing the current database
+ If Not IsNull(oSourceDatabase) Then oSourceDatabase.mClose()
+ End If
Utils._ResetCalledSub(cstThisSub)
Set oSourceCol = Nothing
Set oSourceKey = Nothing
@@ -390,26 +405,30 @@ Dim vFindValue As Variant, oFindrecord As Object
Case vbDate, vbInteger, vbLong,
vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
bFound = ( .FindWhat =
vFindValue )
Case vbString
- Select Case .Match
- Case acStart
- If
.MatchCase Then
-
bFound = ( Left(.FindWhat, Len(.FindWhat)) = vFindValue )
- Else
-
bFound = ( UCase(Left(.FindWhat, Len(.FindWhat))) = UCase(vFindValue) )
- End If
- Case acAnyWhere
- If
.MatchCase Then
-
bFound = ( InStr(1, vFindValue, .FindWhat, 0) > 0 )
- Else
-
bFound = ( InStr(vFindValue, .FindWhat) > 0 )
- End If
- Case acEntire
- If
.MatchCase Then
-
bFound = ( .FindWhat = vFindValue )
- Else
-
bFound = ( UCase(.FindWhat) = UCase(vFindValue) )
- End If
- End Select
+ If VarType(vFindValue)
= vbString Then
+ Select Case
.Match
+ Case
acStart
+
If .MatchCase Then
+
bFound = ( Left(.FindWhat, Len(.FindWhat)) = vFindValue )
+
Else
+
bFound = ( UCase(Left(.FindWhat, Len(.FindWhat))) = UCase(vFindValue) )
+
End If
+ Case
acAnyWhere
+
If .MatchCase Then
+
bFound = ( InStr(1, vFindValue, .FindWhat, 0) > 0 )
+
Else
+
bFound = ( InStr(vFindValue, .FindWhat) > 0 )
+
End If
+ Case
acEntire
+
If .MatchCase Then
+
bFound = ( .FindWhat = vFindValue )
+
Else
+
bFound = ( UCase(.FindWhat) = UCase(vFindValue) )
+
End If
+ End Select
+ Else
+ bFound = False
+ End If
End Select
If bFound Then
.LastColumn = i
diff --git a/wizards/source/access2base/Utils.xba
b/wizards/source/access2base/Utils.xba
index 16f73cd..6f9135c 100644
--- a/wizards/source/access2base/Utils.xba
+++ b/wizards/source/access2base/Utils.xba
@@ -615,7 +615,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 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)
@@ -722,13 +722,22 @@ End Sub ' SetCalledSub
REM
-----------------------------------------------------------------------------------------------------------------------
Public Function _Surround(ByVal psName As String) As String
' Return [Name] if Name contains spaces
+' Return [Name1].[Name2].[Name3] if Name1.Name2.Name3 contains dots
+
Const cstSquareOpen = "["
Const cstSquareClose = "]"
- If InStr(psName, " ") > 0 Then
+Const cstDot = "."
+Dim sName As String
+
+ If InStr(psName, ".") > 0 Then
+ sName = Join(Split(psName, cstDot), cstSquareClose & cstDot
& cstSquareOpen
+ _Surround = cstSquareOpen & sName & cstSquareClose
+ ElseIf InStr(psName, " ") > 0 Then
_Surround = cstSquareOpen & psName & cstSquareClose
Else
_Surround = psName
End If
+
End Function ' Surround
REM
-----------------------------------------------------------------------------------------------------------------------
@@ -851,4 +860,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
_______________________________________________
Libreoffice-commits mailing list
libreoffice-comm...@lists.freedesktop.org
https://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
