From fc0f2c5f88544ae2f5ab208efa137747a14da44d Mon Sep 17 00:00:00 2001 From: Jean-Pierre Ledure Date: Mon, 16 May 2016 12:40:36 +0200 Subject: 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 --- 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(-) (limited to 'wizards') diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba index ae7483b0ac8e..95f81dffb5ea 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 8fe7ec990da7..1b914a4c75dd 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 16f73cd636cd..6f9135cce559 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 - + \ No newline at end of file -- cgit