[Libreoffice-commits] core.git: wizards/source
Jean-Pierre Ledure
jp at ledure.be
Mon May 16 10:44:16 UTC 2016
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 <jp at 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
More information about the Libreoffice-commits
mailing list