diff options
| author | Jean-Pierre Ledure <jp@ledure.be> | 2014-05-10 16:01:47 +0200 |
|---|---|---|
| committer | Lionel Elie Mamane <lionel@mamane.lu> | 2014-05-13 12:30:00 +0000 |
| commit | e6c21ee479b7dbfa11398b8038d7abc26d47f98b (patch) | |
| tree | 96f0b2e29020710e59c7644167c9108416eccc39 | |
| parent | 533237fec4b91fb5f871e0b5028586516dd8c0be (diff) | |
Access2Base new release - V1.1.0
Access2Base library can be run to access a database defined in any form stored
in any AOO/LibO document. Now CurrentDb method may be associated with a form
object, not only with the root class.The OpenDatabase method allows any
AOO/LibO document to get access to tables stored in any database.
RunSQL, OpenSQL, database functions have been extended to be run from
a database object, not only as a command. The CopyObject (new) action copies
query definitions and/or table definitions and data.
Creation of table and fields without SQL with the CreateTableDef, CreateField
and Append methods. The Description property of a TableDef is writable.
New GetHiddenAttribute and SetHiddenAttribute actions hide or show any
AOO/LibO or Base object. SelectObject scope has been extended accordingly.
Addition of the SelStart, SelLength and SelText properties for text controls.
Change-Id: I163f3bcb0f63dc346e1bd23729356ebe556c6592
Reviewed-on: https://gerrit.libreoffice.org/9303
Reviewed-by: Lionel Elie Mamane <lionel@mamane.lu>
Tested-by: Lionel Elie Mamane <lionel@mamane.lu>
22 files changed, 2215 insertions, 854 deletions
diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba index 3497669db5fe..9de68cd4e110 100644 --- a/wizards/source/access2base/Application.xba +++ b/wizards/source/access2base/Application.xba @@ -7,10 +7,6 @@ REM ============================================================================ Option Explicit -'DATABASE -' Name property -' Path property - REM ----------------------------------------------------------------------------------------------------------------------- Global Const TRACEDEBUG = "DEBUG" ' To report values of variables Global Const TRACEINFO = "INFO" ' To report any event @@ -23,12 +19,12 @@ Global Const TRACEANY = "===>" ' Always reported ' FATALs and ABORTs interrupt the program execution Global Const ERRINIT = 1500 -Global Const ERRNOTDATABASE = 1501 -Global Const ERRDBNOTCONNECTED = 1502 -Global Const ERRMISSINGARGUMENTS = 1503 -Global Const ERRWRONGARGUMENT = 1504 -Global Const ERRMAINFORM = 1505 -Global Const ERRSTANDALONE = 1506 +Global Const ERRDBNOTCONNECTED = 1501 +Global Const ERRMISSINGARGUMENTS = 1502 +Global Const ERRWRONGARGUMENT = 1503 +Global Const ERRMAINFORM = 1504 +Global Const ERRMETHOD = 1505 +Global Const ERRFILEACCESS = 1506 Global Const ERRFORMNOTIDENTIFIED = 1507 Global Const ERRFORMNOTFOUND = 1508 Global Const ERRFORMNOTOPEN = 1509 @@ -49,31 +45,36 @@ Global Const ERRSQLSTATEMENT = 1523 Global Const ERROBJECTNOTFOUND = 1524 Global Const ERROPENOBJECT = 1525 Global Const ERRCLOSEOBJECT = 1526 -Global Const ERRMETHOD = 1527 Global Const ERRACTION = 1528 Global Const ERRSENDMAIL = 1529 Global Const ERRFORMYETOPEN = 1530 -Global Const ERRMETHOD = 1531 -Global Const ERRPROPERTYINIT = 1532 -Global Const ERRFILENOTCREATED = 1533 -Global Const ERRDIALOGNOTFOUND = 1534 -Global Const ERRDIALOGUNDEFINED = 1535 -Global Const ERRDIALOGSTARTED = 1536 -Global Const ERRDIALOGNOTSTARTED = 1537 -Global Const ERRRECORDSETNODATA = 1538 -Global Const ERRRECORDSETCLOSED = 1539 -Global Const ERRRECORDSETRANGE = 1540 -Global Const ERRRECORDSETFORWARD = 1541 -Global Const ERRFIELDNULL = 1542 -Global Const ERRFILEACCESS = 1543 -Global Const ERRMEMOLENGTH = 1544 -Global Const ERRNOTACTIONQUERY = 1545 -Global Const ERRNOTUPDATABLE = 1546 -Global Const ERRUPDATESEQUENCE = 1547 -Global Const ERRNOTNULLABLE = 1548 -Global Const ERRROWDELETED = 1549 -Global Const ERRRECORDSETCLONE = 1550 -Global Const ERRQUERYDEFDELETED = 1551 +Global Const ERRPROPERTYINIT = 1531 +Global Const ERRFILENOTCREATED = 1532 +Global Const ERRDIALOGNOTFOUND = 1533 +Global Const ERRDIALOGUNDEFINED = 1534 +Global Const ERRDIALOGSTARTED = 1535 +Global Const ERRDIALOGNOTSTARTED = 1536 +Global Const ERRRECORDSETNODATA = 1537 +Global Const ERRRECORDSETCLOSED = 1538 +Global Const ERRRECORDSETRANGE = 1539 +Global Const ERRRECORDSETFORWARD = 1540 +Global Const ERRFIELDNULL = 1541 +Global Const ERRMEMOLENGTH = 1542 +Global Const ERRNOTACTIONQUERY = 1543 +Global Const ERRNOTUPDATABLE = 1544 +Global Const ERRUPDATESEQUENCE = 1545 +Global Const ERRNOTNULLABLE = 1546 +Global Const ERRROWDELETED = 1547 +Global Const ERRRECORDSETCLONE = 1548 +Global Const ERRQUERYDEFDELETED = 1549 +Global Const ERRTABLEDEFDELETED = 1550 +Global Const ERRTABLECREATION = 1551 +Global Const ERRFIELDCREATION = 1552 + +REM ----------------------------------------------------------------------------------------------------------------------- +Global Const DBCONNECTBASE = 1 ' Connection from Base document (OpenConnection) +Global Const DBCONNECTFORM = 2 ' Connection from a database-aware form (OpenConnection) +Global Const DBCONNECTANY = 3 ' Connection from any document for data access only (OpenDatabase) REM ----------------------------------------------------------------------------------------------------------------------- Global Const COLLALLDIALOGS = "ALLDIALOGS" @@ -139,7 +140,6 @@ Global Const CTLPARENTISGROUP = "OPTIONGROUP" REM ----------------------------------------------------------------------------------------------------------------------- Type Root - ' Single values ErrorHandler As Boolean MinimalTraceLevel As Integer TraceLogs() As Variant @@ -149,7 +149,22 @@ Type Root CalledSub As String Introspection As Object ' com.sun.star.beans.Introspection VersionNumber As String ' Actual Access2Base version number - CurrentDb() As Object ' Array of database objects -{0] = Base file, [1..N] = Writer files + FindRecord As Object + StatusBar As Object + Dialogs As Object ' Collection + CurrentDoc() As Variant ' Array of document containers - [0] = Base document, [1 ... N] = other documents +End Type + +Type DocContainer + Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj + DbConnect As Integer ' DBCONNECTxxx constants + URL As String + DbContainers() As Variant ' One entry by (data-aware) form +End Type + +Type DbContainer + FormName As String ' name of data-aware form + Database As Object ' Database type End Type REM ----------------------------------------------------------------------------------------------------------------------- @@ -173,19 +188,19 @@ Const cstSepar = "!" If IsMissing(pvIndex) Then iMode = cstCount Else - If Not Utils.Utils._CheckArgument(pvIndex, 1, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex End If Set vAllDialogs = Nothing - Set oDocLibraries = ThisComponent.DialogLibraries '_CurrentDb().Document.DialogLibraries + Set oDocLibraries = ThisComponent.DialogLibraries vDocLibraries = oDocLibraries.getElementNames() Set oMacLibraries = DialogLibraries vMacLibraries = oMacLibraries.getElementNames() 'Remove Access2Base from the list For i = 0 To UBound(vMacLibraries) - If vMacLibraries(i) = "Access2Base" Then vMacLibraries(i) = "" + If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = "" Next i vMacLibraries = Utils._TrimArray(vMacLibraries) @@ -258,7 +273,7 @@ Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Not_Found: - TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils.Utils._CalledSub(), 0, , pvIndex) + TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils._CalledSub(), 0, , pvIndex) Goto Exit_Function Trace_Error_Index: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) @@ -283,7 +298,7 @@ Dim iIndex As Integer, vAllForms As Variant Set vAllForms = Nothing If Not IsMissing(pvIndex) Then - If Not Utils.Utils._CheckArgument(pvIndex, 1, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function Select Case VarType(pvIndex) Case vbString iIndex = -1 @@ -292,16 +307,21 @@ Dim iIndex As Integer, vAllForms As Variant End Select End If -Dim oDatabase As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object - Set oDatabase = _CurrentDb() - If Not oDatabase._Standalone Then Set oForms = oDatabase.Document.getFormDocuments() +Dim iCurrentDoc As Integer, vCurrentDoc As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object + iCurrentDoc = Application._CurrentDoc() + If iCurrentDoc >= 0 Then + vCurrentDoc = _A2B_.CurrentDoc(iCurrentDoc) + Else + Goto Exit_Function + End If + If vCurrentDoc.DbConnect = DBCONNECTBASE Then Set oForms = vCurrentDoc.Document.getFormDocuments() ' Process when NO ARGUMENT If IsMissing(pvIndex) Then ' No argument Set oCounter = New Collect oCounter._CollType = COLLALLFORMS oCounter._ParentType = OBJAPPLICATION oCounter._ParentName = "" - If oDatabase._Standalone Then oCounter._Count = 1 Else oCounter._Count = oForms.getCount() + If vCurrentDoc.DbConnect = DBCONNECTFORM Then oCounter._Count = UBound(vCurrentDoc.DbContainers) + 1 Else oCounter._Count = oForms.getCount() Set vAllForms = oCounter Goto Exit_Function End If @@ -309,25 +329,43 @@ Dim oDatabase As Variant, oForms As Variant, oCounter As Variant, oFormsCollecti ' Process when ARGUMENT = STRING or INDEX => Initialize form object Dim ofForm As Object Set ofForm = New Form -Dim sAllForms As Variant, i As Integer, sSub As String, vName As Variant - Select Case oDatabase._Standalone - Case False + Set ofForm._This = ofForm +Dim sAllForms As Variant, i As Integer, vName As Variant, oDatabase As Object, bFound As Boolean + Select Case vCurrentDoc.DbConnect + Case DBCONNECTBASE sAllForms() = oForms.getElementNames() - If iIndex= -1 Then ' String argument - vName = Utils._InList(Utils.Utils._Trim(pvIndex), sAllForms, True) ' hasByName not used because case sensitive + ofForm._DocEntry = 0 + ofForm._DbEntry = 0 + If iIndex= -1 Then ' String argument + vName = Utils._InList(Utils._Trim(pvIndex), sAllForms, True) ' hasByName not used because case sensitive If vName = False Then Goto Trace_Not_Found ofForm._Initialize(vName) Else If iIndex + 1 > oForms.getCount() Or iIndex < 0 Then Goto Trace_Error_Index ' Numeric argument OK but value nonsense ofForm._Initialize(sAllForms(iIndex)) End If - Case True - If iIndex = -1 Then - If UCase(Utils.Utils._Trim(pvIndex)) <> UCase(oDatabase.FormName) Then Goto Trace_Not_Found - ElseIf iIndex <> 0 Then - Goto Trace_Error_Index - End If + Case DBCONNECTFORM + With vCurrentDoc + If iIndex = -1 Then + bFound = False + For i = 0 To UBound(vCurrentDoc.DbContainers) + Set oDatabase = vCurrentDoc.DbContainers(i).Database + If UCase(Utils._Trim(pvIndex)) = UCase(oDatabase.FormName) Then + bFound = True + ofForm._DbEntry = i + Exit For + End If + Next i + If Not bFound Then Goto Trace_Not_Found + ElseIf iIndex < 0 Or iIndex > UBound(vCurrentDoc.DbContainers) Then + Goto Trace_Error_Index + Else + ofForm._DbEntry = iIndex + Set oDatabase = vCurrentDoc.DbContainers(iIndex).Database + End If + End With vName = oDatabase.FormName + ofForm._DocEntry = iCurrentDoc ofForm._Initialize(vName) End Select @@ -382,7 +420,7 @@ Const cstThisSub = "Controls" If IsMissing(pvIndex) Then Controls = vObject.Controls() Else - If Not Utils._CheckArgument(pvIndex, 2, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function + If Not Utils._CheckArgument(pvIndex, 2, Utils._AddNumeric(vbString)) Then Goto Exit_Function Controls = vObject.Controls(pvIndex) End If @@ -396,44 +434,26 @@ End Function ' Controls V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function CurrentDb(Optional pvURL As String) As Object -' Returns _A2B_.CurrentDb(.) as an object to allow access to its properties +' Returns _A2B_.CurrentDoc(.).Database as an object to allow access to its properties ' Parameter only for internal use Const cstThisSub = "CurrentDb" Utils._SetCalledSub(cstThisSub) -Dim i As Integer, bFound As Boolean, sURL As String, oCurrent As Object +Dim i As Integer, bFound As Boolean, sURL As String, iCurrentDoc As Integer, oCurrentDoc As Object bFound = False Set CurrentDb = Nothing With _A2B_ - If Not IsArray(.CurrentDb) Then Goto Exit_Function - If UBound(.CurrentDb) < 0 Then Goto Exit_Function - For i = 1 To UBound(.CurrentDb) ' [0] reserved to database .odb document - Set oCurrent = .CurrentDb(i) - If IsMissing(pvURL) Then ' Not on 1 single line ?!? - If Utils.Utils._hasUNOProperty(ThisComponent, "URL") Then - sURL = ThisComponent.URL - Else - Exit For ' f.i. ThisComponent = Basic IDE ... - End If - Else - sURL = pvURL ' To support the SelectObject action - End If - If .CurrentDb(i).URL = sURL Then - Set CurrentDb = oCurrent - bFound = True - Exit For - End If - Next i - If Not bFound Then - If Not IsNull(.CurrentDb(0)) Then Set CurrentDb = .CurrentDb(0) - End If + If Not IsArray(.CurrentDoc) Then Goto Exit_Function + If UBound(.CurrentDoc) < 0 Then Goto Exit_Function + iCurrentDoc = _CurrentDoc() + If iCurrentDoc >= 0 Then Set CurrentDb = .CurrentDoc(iCurrentDoc).DbContainers(0).Database End With Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function -End Function ' CurrentDb V0.9.5 +End Function ' CurrentDb V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function CurrentUser() As String @@ -461,7 +481,7 @@ Public Function DAvg( _ Const cstThisSub = "DAvg" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DAvg = Application._DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + DAvg = Application._CurrentDb()._DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") Utils._ResetCalledSub(cstThisSub) End Function ' DAvg @@ -475,7 +495,7 @@ Public Function DCount( _ Const cstThisSub = "DCount" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DCount = Application._DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + DCount = Application._CurrentDb()._DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") Utils._ResetCalledSub(cstThisSub) End Function ' DCount @@ -503,7 +523,7 @@ Public Function DLookup( _ Const cstThisSub = "DLookup" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DLookup = Application._DFunction("", psExpr, psDomain _ + DLookup = Application._CurrentDb()._DFunction("", psExpr, psDomain _ , Iif(IsMissing(pvCriteria), "", pvCriteria) _ , Iif(IsMissing(pvOrderClause), "", pvOrderClause) _ ) @@ -520,7 +540,7 @@ Public Function DMax( _ Const cstThisSub = "DMax" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DMax = Application._DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + DMax = Application._CurrentDb()._DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") Utils._ResetCalledSub(cstThisSub) End Function ' DMax @@ -534,7 +554,7 @@ Public Function DMin( _ Const cstThisSub = "DMin" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DMin = Application._DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + DMin = Application._CurrentDb()._DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") Utils._ResetCalledSub(cstThisSub) End Function ' DMin @@ -548,7 +568,7 @@ Public Function DStDev( _ Const cstThisSub = "DStDev" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DStDev = Application._DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + DStDev = Application._CurrentDb()._DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! Utils._ResetCalledSub(cstThisSub) End Function ' DStDev @@ -562,7 +582,7 @@ Public Function DStDevP( _ Const cstThisSub = "DStDevP" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DStDevP = Application._DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + DStDevP = Application._CurrentDb()._DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! Utils._ResetCalledSub(cstThisSub) End Function ' DStDevP @@ -576,7 +596,7 @@ Public Function DSum( _ Const cstThisSub = "DSum" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DSum = Application._DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + DSum = Application._CurrentDb()._DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") Utils._ResetCalledSub(cstThisSub) End Function ' DSum @@ -590,7 +610,7 @@ Public Function DVar( _ Const cstThisSub = "DVar" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DVar = Application._DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + DVar = Application._CurrentDb()._DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") Utils._ResetCalledSub(cstThisSub) End Function ' DVar @@ -604,7 +624,7 @@ Public Function DVarP( _ Const cstThisSub = "DVarP" Utils._SetCalledSub(cstThisSub) If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() - DVarP = Application._DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + DVarP = Application._CurrentDb()._DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") Utils._ResetCalledSub(cstThisSub) End Function ' DVarP @@ -621,7 +641,8 @@ Const cstThisSub = "Events" If IsMissing(poEvent) Then Goto Exit_Function If IsNull(poEvent) Then Goto Exit_Function - If Not Utils.Utils._hasUNOProperty(poEvent, "Source") Then Goto Trace_Error + If Not Utils._CheckArgument(poEvent, 1, vbObject) Then Goto Exit_Function + If Not Utils._hasUNOProperty(poEvent, "Source") Then Goto Trace_Error Set vEvent = New Event vEvent._Initialize(poEvent) @@ -634,7 +655,7 @@ Error_Function: GoTo Exit_Function Trace_Error: ' Errors are not displayed to avoid display infinite cycling - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, Utils.Utils._CStr(poEvent)) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, Array(1, Utils._CStr(poEvent))) Set vEvent = Nothing Goto Exit_Function End Function ' Events V0.9.1 @@ -663,12 +684,12 @@ Dim iCount As Integer Forms = oCounter Exit Function Else - If Not Utils._CheckArgument(pvIndex, 1, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function End If Select Case VarType(pvIndex) Case vbString - Set ofForm = Application.AllForms(Utils.Utils._Trim(pvIndex)) + Set ofForm = Application.AllForms(Utils._Trim(pvIndex)) Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal iCount = Application._CountOpenForms() If iCount <= pvIndex Then Goto Trace_Error_Index @@ -690,7 +711,7 @@ Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Error: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , 1) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvIndex)) Set vForms = Nothing Goto Exit_Function Trace_Error_Index: @@ -703,119 +724,262 @@ Error_Function: End Function ' Forms V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- -Public Sub OpenConnection ( _ +Public Function OpenConnection ( _ Optional pvComponent As Variant _ , ByVal Optional pvUser As Variant _ , ByVal Optional pvPassword As Variant _ - ) + ) As Object ' Establish connection with the database designated in the currently open front-end (.odb) document ' Call template: ' Call OpenConnection(ThisDatabaseDocument[, "", ""]) ' Call stored in the OpenDocument event of the front-end database document 'OR -' Initiates processing of a standalone (Writer) form (V0.8.0) +' Initiates processing of a (standalone ?) Writer, Calc, ... document with 1 or more data-aware forms ' Call template: ' Call OpenConnection(ThisComponent[, "", ""]) -' Call stored in the OpenDocument event of the standalone form +' Call stored in the OpenDocument event of the document +' +' User and Password arguments are obsolete (still tolerated) +' - because no mean has been found to connect protected db from .odb via API +' - because having multiple forms with multiple db's and multiple passwords is meaningless -Dim odbDatabase As Variant, oComponent As Object, oForm As Object, iCurrent As Integer +Dim oComponent As Object, oForms As Object, iCurrent As Integer Dim i As Integer, bFound As Boolean -Dim vCurrentDb() As Variant +Dim vCurrentDoc() As Variant +Dim oBaseContext As Object, sDbNames() As String, oBaseSource As Object +Dim sDatabaseURL As String, oHandler As Object +Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant +Dim sFormName As String, oConnection As Object If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session + Set OpenConnection = Nothing - If _ErrorHandler() Then On Local Error Goto Error_Sub + If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "OpenConnection" Utils._SetCalledSub(cstThisSub) If IsMissing(pvComponent) Then Call _TraceArguments() - If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Sub + If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Function Set oComponent = pvComponent If Not Utils._hasUNOProperty(oComponent, "ImplementationName") Then - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, 1) - Exit Sub + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(1, oComponent)) + Exit Function End If If IsMissing(pvUser) Then pvUser = "" If IsMissing(pvPassword) Then pvPassword = "" - If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Sub - If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Sub - - If Not IsArray(_A2B_.CurrentDb) Then vCurrentDb = Array() Else vCurrentDb = _A2B_.CurrentDb + If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function - Set odbDatabase = New Database + If Not IsArray(_A2B_.CurrentDoc) Then + vCurrentDoc() = Array() + Redim vCurrentDoc(0 To 0) ' Create at least one entry for database document + Else + vCurrentDoc() = _A2B_.CurrentDoc() + End If + + ' Find index of entry to use for new connection + With oComponent + Select Case .ImplementationName + Case "com.sun.star.comp.dba.ODatabaseDocument" + iCurrent = 0 + Case Else ' "SwXTextDocument", "ScModelObj" + If UBound(vCurrentDoc) <= 0 Then ' First Calc or Writer during current session + iCurrent = 1 + Else ' Search entry already used earlier by same component + bFound = False + For i = 1 To UBound(vCurrentDoc) + If Not IsEmpty(vCurrentDoc(i)) Then + If vCurrentDoc(i).URL = .URL Then + iCurrent = i + bFound = True + Exit For + End If + End If + Next i + End If + If Not bFound Then + iCurrent = UBound(vCurrentDoc) + 1 ' No entry found, increment array + ReDim Preserve vCurrentDoc(0 To iCurrent) + End If + End Select + End With + + ' Initialize future entry + Set vDocContainer = New DocContainer + Set vDocContainer.Document = oComponent + vDocContainer.URL = oComponent.URL + ' Initialize each DbContainer entry + vDbContainers() = Array() + TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False) Select Case oComponent.ImplementationName - Case "com.sun.star.comp.dba.ODatabaseDocument" - If Not oComponent.CurrentController.IsConnected Then oComponent.CurrentController.Connect(pvUser, pvPassword) - Set odbDatabase.Connection = oComponent.CurrentController.ActiveConnection - odbDatabase._Standalone = False - Case "SwXTextDocument" - Set oForm = oComponent.CurrentController.Model.DrawPage.Forms - If oForm.Count <> 1 Then Goto Error_MainForm - odbDatabase.FormName = oForm.ElementNames(0) - odbDatabase.Form = oForm.getByName(odbDatabase.FormName) - Set odbDatabase.Connection = odbDatabase.Form.ActiveConnection - odbDatabase._Standalone = True + Case "com.sun.star.comp.dba.ODatabaseDocument" ' Ignore pvUser and pvPassword arguments + vDbContainer = New DbContainer + vDbContainer.FormName = "" + Set vDbContainer.Database = New Database + Set vDbContainer.Database._This = vDbContainer.Database + With vDbContainer.Database + If Not oComponent.CurrentController.IsConnected Then + Set oHandler = createUnoService("com.sun.star.sdb.InteractionHandler") + Set .Connection = oComponent.DataSource.connectWithCompletion(oHandler) + oComponent.CurrentController.connect() + Else + Set .Connection = oComponent.CurrentController.ActiveConnection + End If + vDocContainer.DbConnect = DBCONNECTBASE + ._DbConnect = DBCONNECTBASE + Set .MetaData = .Connection.MetaData + ._ReadOnly = .Connection.isReadOnly() + Set .Document = oComponent + .Title = oComponent.Title + .URL = vDocContainer.URL + ReDim vDbContainers(0 To 0) + Set vDbContainers(0) = vDbContainer + TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False) + TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL, False) + End With Case Else - TraceError(TRACEFATAL, ERRNOTDATABASE, Utils._CalledSub(), 0, , 1) - End Select + Set oForms = oComponent.CurrentController.Model.DrawPage.Forms + If oForms.Count < 1 Then Goto Error_MainForm + ReDim vDbContainers(0 To oForms.Count - 1) + For i = 0 To oForms.Count - 1 + vDbContainer = New DbContainer ' To make distinct entries !! + sFormName = oForms.ElementNames(i) + Set oConnection = oForms.getByName(sFormName).ActiveConnection + If IsNull(oConnection) Then + Set vDbContainer.Database = Nothing ' Form is not data-aware + Else + Set vDbContainer.Database = New Database + Set vDbContainer.Database._This = vDbContainer.Database + With vDbContainer.Database + .FormName = sFormName + vDbContainer.FormName = sFormName + Set .Form = oForms.getByName(sFormName) + Set .Connection = oConnection + Set .MetaData = oConnection.MetaData + ._ReadOnly = oConnection.isReadOnly() + Set .Document = oComponent + .Title = oComponent.Title + .URL = .Form.DataSourceName + ._DbConnect = DBCONNECTFORM + Set vDbContainers(i) = vDbContainer + vDbContainers(i).FormName = sFormName + TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False) + TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL & " Form=" & vDbContainer.FormName, False) + End With + End If + Next i + vDocContainer.DbConnect = DBCONNECTFORM + End Select + + vDocContainer.DbContainers() = vDbContainers() + Set vCurrentDoc(iCurrent) = vDocContainer + + _A2B_.CurrentDoc = vCurrentDoc + Set OpenConnection = vDbContainers(0).Database + + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + Set _A2B_.CurrentDoc = Array() + GoTo Exit_Function +Error_MainForm: + TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title) + Set _A2B_.CurrentDoc = Array() + GoTo Exit_Function +Trace_Error: + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1) + Goto Exit_Function +End Function ' OpenConnection V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenDatabase ( _ + ByVal Optional pvDatabaseURL As Variant _ + , ByVal Optional pvUser As Variant _ + , ByVal Optional pvPassword As Variant _ + , ByVal Optional pvReadOnly As Variant _ + ) As Object + +' Return a database object based on input arguments: +' Call template: +' Call OpenConnection("... 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 + +Dim odbDatabase As Variant, oBaseContext As Object, sDbNames() As String, oBaseSource As Object +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 + Set OpenDatabase = Nothing + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "OpenDatabase" + Utils._SetCalledSub(cstThisSub) + If pvDatabaseURL = "" Then Call _TraceArguments() + If Not Utils._CheckArgument(pvDatabaseURL, 1, vbString) Then Goto Exit_Function + If IsMissing(pvUser) Then pvUser = "" + If IsMissing(pvPassword) Then pvPassword = "" + If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function + If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function + If IsMissing(pvReadOnly) Then pvReadOnly = False + If Not Utils._CheckArgument(pvReadOnly, 3, vbBoolean) Then Goto Exit_Function + Set odbDatabase = New Database + Set odbDatabase._This = odbDatabase + odbDatabase._DbConnect = DBCONNECTANY + + Set oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") + sDbNames() = oBaseContext.getElementNames() + bFound = False + For i = 0 To UBound(sDbNames() ' Enumerate registered databases and check non case-sensitive equality + If UCase(sDbNames(i)) = UCase(pvDatabaseURL) Then + sDatabaseURL = sDbNames(i) + Set oBaseSource = oBaseContext.getByName(sDatabaseURL) + bFound = True + Exit For + End If + Next i + If Not bFound Then + sDatabaseURL = ConvertToURL(pvDatabaseURL) + If UCase(Right(sDatabaseURL, 4)) <> ".ODB" Then Goto Trace_Error + If Not FileExists(sDatabaseURL) Then Goto Trace_Error + Set oBaseSource = oBaseContext.getByName(sDatabaseURL) + End If + + 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 + Else + Goto Trace_Error End If - Set odbDatabase.Document = oComponent - odbDatabase.Title = oComponent.Title - odbDatabase.URL = oComponent.URL + + odbDatabase.URL = sDatabaseURL - If UBound(vCurrentDb) < 0 Then ' NOT ON 1 SINGLE LINE !!! - Redim vCurrentDb(0 To 0) + If pvReadOnly Then + odbDatabase.Connection.isReadOnly = True + odbDatabase._ReadOnly = True End If - Select Case odbDatabase._Standalone ' Find entry to use for new connection - Case True - If UBound(vCurrentDb) <= 0 Then - iCurrent = 1 - Else ' Search entry already used earlier by same component - bFound = False - For i = 1 To UBound(vCurrentDb) - If Not IsEmpty(vCurrentDb(i)) Then - If vCurrentDb(i)._Standalone And vCurrentDb(i).URL = odbDatabase.URL Then - iCurrent = i - bFound = True - Exit For - End If - End If - Next i - End If - If Not bFound Then - iCurrent = UBound(vCurrentDb) + 1 ' No entry found, increment array - ReDim Preserve vCurrentDb(0 To iCurrent) - End If - Set vCurrentDb(iCurrent) = odbDatabase - Case False - Set vCurrentDb(0) = odbDatabase - End Select + Set OpenDatabase = odbDatabase - _A2B_.CurrentDb = vCurrentDb - - TraceLog(TRACEANY, Utils._GetProductName() & " - Access2Base " & _A2B_.VersionNumber, False) - If IsNull(odbDatabase.Connection) Then Goto Trace_Error + TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False) TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() & " " & odbDatabase.MetaData.getDatabaseProductVersion, False) + TraceLog(TRACEANY, UCase(cstThisSub) & " " & odbDatabase.URL, False) + -Exit_Sub: +Exit_Function: Utils._ResetCalledSub(cstThisSub) - Exit Sub -Error_Sub: + Exit Function +Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) - Set _A2B_.CurrentDb = Array() - GoTo Exit_Sub -Error_MainForm: - TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title) - Set _A2B_.CurrentDb = Array() - GoTo Exit_Sub + GoTo Exit_Function Trace_Error: TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1) - Goto Exit_Sub -End Sub ' OpenConnection V0.9.1 + Goto Exit_Function +End Function ' OpenDatabase V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function ProductCode() @@ -838,7 +1002,7 @@ Const cstThisSub = "SysCmd" Const cstMissing = -1 Const cstBarLength = 350 If IsMissing(pvAction) Then Call _TraceArguments() - If Not Utils._CheckArgument(pvAction, 1, Utils.Utils._AddNumeric(), Array( _ + If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric(), Array( _ acSysCmdAccessDir _ , acSysCmdAccessVer _ , acSysCmdClearHelpTopic _ @@ -854,7 +1018,7 @@ Const cstBarLength = 350 , acSysCmdUpdateMeter _ )) Then Goto Exit_Function If IsMissing(pvValue) Then pvValue = cstMissing - If Not Utils._CheckArgument(pvAction, 1, Utils.Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric()) Then Goto Exit_Function Select Case pvAction Case acSysCmdInitMeter, acSysCmdUpdateMeter, acSysCmdSetStatus If IsMissing(pvText) Then Call _TraceArguments() @@ -863,9 +1027,8 @@ Const cstBarLength = 350 End Select If Not Utils._CheckArgument(pvValue, 3, Utils._AddNumeric()) Then Goto Exit_Function -Dim vBar As Variant, oDb As Object, iLen As Integer - Set oDb = _CurrentDb() - Set vBar = oDb.StatusBar +Dim vBar As Variant, iLen As Integer + Set vBar = _A2B_.StatusBar Select Case pvAction Case acSysCmdAccessVer SysCmd = Application.Version() @@ -879,7 +1042,7 @@ Dim vBar As Variant, oDb As Object, iLen As Integer If pvValue <> cstMissing Then Goto Error_Arg If Not IsNull(vBar) Then vBar.end() - Set oDb.StatusBar = Nothing + Set _A2B_.StatusBar = Nothing End If Case acSysCmdInitMeter If pvValue = cstMissing Then Call _TraceArguments() @@ -894,7 +1057,7 @@ Dim vBar As Variant, oDb As Object, iLen As Integer Case acSysCmdRemoveMeter If Not IsNull(vBar) Then vBar.end() - Set oDb.StatusBar = Nothing + Set _A2B_.StatusBar = Nothing End If Case acSysCmdRuntime SysCmd = False @@ -934,6 +1097,7 @@ Dim i As Integer, iCount As Integer, iAllCount As Integer, ofForm As Variant iCount = 0 If iAllCount > 0 Then Set ofForm = New Form + Set ofForm._This = ofForm For i = 0 To iAllCount - 1 Set ofForm = Application.AllForms(i) If ofForm.IsLoaded Then iCount = iCount + 1 @@ -948,103 +1112,106 @@ Dim i As Integer, iCount As Integer, iAllCount As Integer, ofForm As Variant If IsMissing(piCountMax) Then _CountOpenForms = iCount -End Function ' CountOpenForms V0.9.0 +End Function ' CountOpenForms V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function _CurrentDb() As Variant -REM Same as CurrentDb() except that it generates an error if database not connected (internal use) +Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant +REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use) +REM With 2 arguments return the corresponding entry in Root Dim odbDatabase As Variant - Set odbDatabase = Application.CurrentDb() + If IsMissing(piDocEntry) Then + Set odbDatabase = Application.CurrentDb() + Else + With _A2B_ + If Not IsArray(.CurrentDoc) Then Goto Trace_Error + If piDocEntry < 0 Or piDbEntry < 0 Then Goto Trace_Error + If piDocEntry > UBound(.CurrentDoc) Then Goto Trace_Error + If piDbEntry > UBound(.CurrentDoc(piDocEntry).DbContainers) Then Goto Trace_Error + Set odbDatabase = .CurrentDoc(piDocEntry).DbContainers(piDbEntry).Database + End With + End If If IsNull(odbDatabase) Then GoTo Trace_Error Exit_Function: Set _CurrentDb = odbDatabase Exit Function Trace_Error: - TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1) + TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1) Goto Exit_Function -End Function ' _CurrentDb +End Function ' _CurrentDb V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- -Private Function _DFunction(ByVal psFunction As String _ - , ByVal psExpr As String _ - , ByVal psDomain As String _ - , ByVal pvCriteria As Variant _ - , ByVal Optional pvOrderClause As Variant _ - ) As Variant - 'Arguments: psFunction an optional aggregate function - ' psExpr: an SQL expression [might contain an aggregate function] - ' psDomain: a table- or queryname - ' pvCriteria: an optional WHERE clause - ' pcOrderClause: an optional order clause incl. "DESC" if relevant +Public Function _CurrentDoc(Optional pvURL As String) As Integer +' Returns the entry in _A2B_.CurrentDoc(...) referring to the current document + +Dim i As Integer, bFound As Boolean, sURL As String + + bFound = False + _CurrentDoc = -1 ' Convention for _A2B_ not initalized or no entry found + With _A2B_ + If Not IsArray(.CurrentDoc) Then Goto Exit_Function + If UBound(.CurrentDoc) < 0 Then Goto Exit_Function + For i = 1 To UBound(.CurrentDoc) ' [0] reserved to database .odb document + If IsMissing(pvURL) Then ' Not on 1 single line ?!? + If Utils._hasUNOProperty(ThisComponent, "URL") Then + sURL = ThisComponent.URL + Else + Exit For ' f.i. ThisComponent = Basic IDE ... + End If + Else + sURL = pvURL ' To support the SelectObject action + End If + If .CurrentDoc(i).URL = sURL Then + _CurrentDoc = i + bFound = True + Exit For + End If + Next i + If Not bFound Then + If Not IsNull(.CurrentDoc(0)) Then _CurrentDoc = 0 + End If + End With -If _ErrorHandler() Then On Local Error GoTo Error_Function - -Dim oResult As Object 'To retrieve the value to find. -Dim vResult As Variant 'Return value for function. -Dim sSql As String 'SQL statement. -Dim oStatement As Object 'For CreateStatement method -Dim sExpr As String 'For inclusion of aggregate function - - vResult = Null - - If psFunction = "" Then sExpr = "TOP 1 " & psExpr Else sExpr = UCase(psFunction) & "(" & psExpr & ")" - - sSql = "SELECT " & sExpr & " AS XXRESULTFIELDXX FROM " & psDomain - If pvCriteria <> "" Then - sSql = sSql & " WHERE " & pvCriteria - End If - If pvOrderClause <> "" Then - sSql = sSql & " ORDER BY " & pvOrderClause - End If - sSql = Utils._ReplaceSquareBrackets(sSql) 'Substitute [] by quote string - - 'Lookup the value. -Dim oDatabase As Object - Set oStatement = _CurrentDb.Connection.createStatement() - With oStatement - .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY - .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY - .EscapeProcessing = False - Set oResult = .executeQuery(sSql) - If Not IsNull(oResult) And Not IsEmpty(oResult) Then - If Not oResult.next() Then Goto Exit_Function - vResult = Utils._getResultSetColumnValue(oResult, 1) - End If - End With +Exit_Function: + Exit Function +End Function ' _CurrentDoc V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _hasDialog(ByVal psName As String) As Boolean +' Return True if psName if in the collection of started dialogs + +Dim oDialog As Object + On Local Error Goto Error_Function ' Whatever ErrorHandler ! + Set oDialog = _A2B_.Dialogs.Item(UCase(psName)) + _hasDialog = True Exit_Function: - 'Assign the returned value. - _DFunction = vResult - Set oResult = Nothing - Set oStatement = Nothing - Exit Function -Error_Function: - TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL) - Goto Exit_Function -End Function ' DFunction V0.9.5 + Exit Function +Error_Function: ' Item by key aborted + _hasDialog = False + GoTo Exit_Function +End Function ' _hasDialog V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _NewBar() As Object ' Close current status bar, if any, and initialize new one -Dim vBar As Variant, vWindow As Variant, oDb As Object, vController As Object +Dim vBar As Variant, vWindow As Variant, vController As Object On Local Error Resume Next Set _NewBar = Nothing - Set oDb = Application._CurrentDb() - Set vBar = oDb.StatusBar + Set vBar = _A2B_.StatusBar If Not IsNull(vBar) Then If Utils._hasUNOMethod(vBar, "end") Then vBar.end() - Set oDb.StatusBar = Nothing + Set _A2B_.StatusBar = Nothing End If Set vBar = Nothing Set vWindow = _SelectWindow() If IsNull(vWindow.Frame) Then Exit Function Select Case vWindow.WindowType - Case acForm, acReport, acBasicIDE ' Not found how to make it work for acDatabaseWindow + Case acForm, acReport, acBasicIDE, acDocument ' Not found how to make it work for acDatabaseWindow Case Else Exit Function End Select @@ -1055,17 +1222,17 @@ Dim vBar As Variant, vWindow As Variant, oDb As Object, vController As Object End If If Utils._hasUNOMethod(vController, "getStatusIndicator") Then vBar = vController.getStatusIndicator() - Set oDb.StatusBar = vBar + Set _A2B_.StatusBar = vBar Set _NewBar = vBar Exit Function -End Function ' _NewBar V0.9.1 +End Function ' _NewBar V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _RootInit() ' Initialize _A2B_ global variable -Dim vRoot As Root +Dim vRoot As Root, vCurrentDoc() As Variant If IsEmpty(_A2B_) Then _A2B_ = vRoot With _A2B_ @@ -1078,8 +1245,15 @@ Dim vRoot As Root .TraceLogMaxEntries = 0 .CalledSub = "" .Introspection = Nothing + Set .FindRecord = Nothing + Set .StatusBar = Nothing + Set .Dialogs = New Collection + vCurrentDoc() = Array() + ReDim vCurrentDoc(0 To 0) + Set vCurrentDoc(0) = Nothing + Set .CurrentDoc() = vCurrentDoc() End With End If -End Sub ' _RootInit V0.9.1 +End Sub ' _RootInit V1.1.0 </script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Collect.xba b/wizards/source/access2base/Collect.xba index 34abbfb8ee06..80c53a0966ab 100644 --- a/wizards/source/access2base/Collect.xba +++ b/wizards/source/access2base/Collect.xba @@ -16,11 +16,12 @@ REM ---------------------------------------------------------------------------- REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- -Private _Type As String ' Must be COLLECTION -Private _CollType As String -Private _ParentType As String -Private _ParentName As String ' Name or shortcut -Private _Count As Long +Private _Type As String ' Must be COLLECTION +Private _CollType As String +Private _ParentType As String +Private _ParentName As String ' Name or shortcut +Private _ParentDatabase As Object +Private _Count As Long REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- @@ -51,7 +52,7 @@ Property Get Item(ByVal Optional pvItem As Variant) As Variant Const cstThisSub = "Collection.getItem" Utils._SetCalledSub(cstThisSub) - If IsMissing(pvItem) Then Call _TraceArguments() + If IsMissing(pvItem) Then Goto Exit_Function ' To allow object watching in Basic IDE, do not generate error If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function Dim vNames() As Variant, oProperty As Object @@ -78,47 +79,47 @@ Dim vNames() As Variant, oProperty As Object Case COLLFIELDS Select Case _ParentType Case OBJQUERYDEF - Set Item = Application.CurrentDb().QueryDefs(_ParentName).Fields(pvItem) + Set Item = _ParentDatabase.QueryDefs(_ParentName).Fields(pvItem) ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Case OBJRECORDSET - Set Item = Application.CurrentDb().Recordsets(_ParentName).Fields(pvItem) + Set Item = _ParentDatabase.Recordsets(_ParentName).Fields(pvItem) Case OBJTABLEDEF - Set Item = Application.CurrentDb().TableDefs(_ParentName).Fields(pvItem) + Set Item = _ParentDatabase.TableDefs(_ParentName).Fields(pvItem) End Select Case COLLPROPERTIES Select Case _ParentType Case OBJCONTROL, OBJSUBFORM Set Item = getObject(_ParentName).Properties(pvItem) Case OBJDATABASE - Set Item = Application.CurrentDb().Properties(pvItem) + Set Item = _ParentDatabase.Properties(pvItem) Case OBJDIALOG Set Item = Application.AllDialogs(_ParentName).Properties(pvItem) Case OBJFIELD vNames() = Split(_ParentName, "/") Select Case vNames(0) Case OBJQUERYDEF - Set Item = Application.CurrentDb().QueryDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem) + Set Item = _ParentDatabase.QueryDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem) Case OBJRECORDSET - Set Item = Application.CurrentDb().Recordsets(vNames(1)).Fields(vNames(2)).Properties(pvItem) + Set Item = _ParentDatabase.Recordsets(vNames(1)).Fields(vNames(2)).Properties(pvItem) Case OBJTABLEDEF - Set Item = Application.CurrentDb().TableDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem) + Set Item = _ParentDatabase.TableDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem) End Select Case OBJFORM Set Item = Application.Forms(_ParentName).Properties(pvItem) Case OBJQUERYDEF - Set Item = Application.CurrentDb().QueryDefs(_ParentName).Properties(pvItem) + Set Item = _ParentDatabase.QueryDefs(_ParentName).Properties(pvItem) Case OBJRECORDSET - Set Item = Application.CurrentDb().Recordsets(_ParentName).Properties(pvItem) + Set Item = _ParentDatabase.Recordsets(_ParentName).Properties(pvItem) Case OBJTABLEDEF - Set Item = Application.CurrentDb().TableDefs(_ParentName).Properties(pvItem) - Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP + Set Item = _ParentDatabase.TableDefs(_ParentName).Properties(pvItem) + Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY ' NOT SUPPORTED End Select Case COLLQUERYDEFS - Set Item = Application.CurrentDb().QueryDefs(pvItem) + Set Item = _ParentDatabase.QueryDefs(pvItem) Case COLLRECORDSETS - Set Item = Application.CurrentDb().Recordsets(pvItem) + Set Item = _ParentDatabase.Recordsets(pvItem) Case COLLTABLEDEFS - Set Item = Application.CurrentDb().TableDefs(pvItem) + Set Item = _ParentDatabase.TableDefs(pvItem) Case Else End Select @@ -128,7 +129,7 @@ Error_Function: TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) Set Item = Nothing GoTo Exit_Function -End Property ' V0.9.5 +End Property ' V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Property Get ObjectType() As String @@ -160,6 +161,100 @@ REM ---------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Append(Optional pvObject As Variant) As Boolean +' Append a new TableDef or Field object to the TableDefs/Fields collections + +Const cstThisSub = "Collection.Append" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim odbDatabase As Object, oConnection As Object, oTables As Object, sName As String, oTable As Object + Append = False + If IsMissing(pvObject) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObject, 1, vbObject) Then Goto Exit_Function + + With pvObject + Select Case ._Type + Case OBJTABLEDEF + Set odbDatabase = ._ParentDatabase + If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + Set oConnection = odbDatabase.Connection + If IsNull(.TableDescriptor) Or .TableFieldsCount = 0 Then Goto Error_Sequence + Set oTables = oConnection.getTables() + oTables.appendByDescriptor(.TableDescriptor) + Set .Table = oTables.getByName(._Name) + .TableDescriptor.dispose() + Set .TableDescriptor = Nothing + .TableFieldsCount = 0 + .TableKeysCount = 0 + Case Else + Goto Error_NotApplicable + End Select + End With + + Append = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Sequence: + TraceError(TRACEFATAL, ERRTABLECREATION, Utils._CalledSub(), 0, 1, pvObject._Name) + Goto Exit_Function +End Function ' Append V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Delete(ByVal Optional pvName As Variant) As Boolean +' Delete a TableDef or QueryDef object in the TableDefs/QueryDefs collections + +Const cstThisSub = "Collection.Delete" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim odbDatabase As Object, oColl As Object, vName As Variant + Delete = False + If IsMissing(pvName) Then pvName = "" + If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function + If pvName = "" Then Call _TraceArguments() + + Select Case _CollType + Case COLLTABLEDEFS, COLLQUERYDEFS + If Application._CurrentDoc <> 0 Then Goto Error_NotApplicable + Set odbDatabase = Application._CurrentDb() + If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If _CollType = COLLTABLEDEFS Then Set oColl = odbDatabase.Connection.getTables() Else Set oColl = odbDatabase.Connection.getQueries() + With oColl + vName = _InList(pvName, .getElementNames(), True) + If vName = False Then Goto trace_NotFound + .dropByName(vName) + End With + odbDatabase.Document.store() + Case Else + Goto Error_NotApplicable + End Select + + Delete = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Left(_CollType, 5)), pvName)) + Goto Exit_Function +End Function ' Delete V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant ' Return property value of psProperty property name @@ -183,7 +278,7 @@ REM ---------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant - _PropertiesList = Array("Count", "ObjectType") + _PropertiesList = Array("Count", "Item", "ObjectType") End Function ' _PropertiesList REM ----------------------------------------------------------------------------------------------------------------------- @@ -197,6 +292,7 @@ Private Function _PropertyGet(ByVal psProperty As String) As Variant Select Case UCase(psProperty) Case UCase("Count") _PropertyGet = _Count + Case UCase("Item") Case UCase("ObjectType") _PropertyGet = _Type Case Else @@ -207,7 +303,7 @@ Exit_Function: Utils._ResetCalledSub("Collection.get" & psProperty) Exit Function Trace_Error: - TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) _PropertyGet = Nothing Goto Exit_Function Error_Function: diff --git a/wizards/source/access2base/Control.xba b/wizards/source/access2base/Control.xba index 42ff713ea7ff..7e15a1d6800c 100644 --- a/wizards/source/access2base/Control.xba +++ b/wizards/source/access2base/Control.xba @@ -21,6 +21,8 @@ Private _ParentType As String ' One of CTLPARENTISxxxx constants Private _Shortcut As String Private _Name As String Private _FormComponent As Object ' com.sun.star.text.TextDocument +Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure +Private _DbEntry As Integer Private _ControlType As Integer Private _SubType As String Private ControlModel As Object ' com.sun.star.comp.forms.XXXModel @@ -37,6 +39,9 @@ Private Sub Class_Initialize() _ParentType = "" _Shortcut = "" _Name = "" + Set _FormComponent = Nothing + _DocEntry = -1 + _DbEntry = -1 _SubType = "" Set ControlModel = Nothing Set ControlView = Nothing @@ -358,6 +363,33 @@ Public Function SelectedI(ByVal pvValue As variant, ByVal pvIndex As Variant) End Function REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SelLength() As Variant + SelLength = _PropertyGet("SelLength") +End Property ' SelLength (get) + +Property Let SelLength(ByVal pvValue As Variant) + Call _PropertySet("SelLength", pvValue) +End Property ' SelLength (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SelStart() As Variant + SelStart = _PropertyGet("SelStart") +End Property ' SelStart (get) + +Property Let SelStart(ByVal pvValue As Variant) + Call _PropertySet("SelStart", pvValue) +End Property ' SelStart (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get SelText() As Variant + SelText = _PropertyGet("SelText") +End Property ' SelText (get) + +Property Let SelText(ByVal pvValue As Variant) + Call _PropertySet("SelText", pvValue) +End Property ' SelText (set) + +REM ----------------------------------------------------------------------------------------------------------------------- Property Get SpecialEffect() As Variant SpecialEffect = _PropertyGet("SpecialEffect") End Property ' SpecialEffect (get) @@ -569,21 +601,19 @@ Dim j As Integer, oView As Object Next i ocControl._Initialize() + ocControl._DocEntry = _DocEntry + ocControl._DbEntry = _DbEntry Set Controls = ocControl Exit_Function: Utils._ResetCalledSub("Grid.Controls") Exit Function -Trace_Error: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , 1) - Set Controls = Nothing - Goto Exit_Function Trace_Error_Index: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) Set Controls = Nothing Goto Exit_Function Trace_NotFound: - TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, vObject._Name)) + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name)) Set Controls = Nothing Goto Exit_Function Trace_Error_Context: @@ -684,11 +714,11 @@ Error_Function: RemoveItem = False GoTo Exit_Function Error_Control: - TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0) + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.RemoveItem") RemoveItem = False Goto Exit_Function Error_Index: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,2) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(2, pvIndex)) RemoveItem = False Goto Exit_Function End Function ' RemoveItem V0.9.1 @@ -720,7 +750,7 @@ Exit_Function: Utils._ResetCalledSub("Control.Requery") Exit Function Error_Control: - TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0) + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.Requery") Requery = False Goto Exit_Function Error_Function: @@ -981,6 +1011,9 @@ Dim vFullPropertiesList() As Variant , "RowSource" _ , "RowSourceType" _ , "Selected" _ + , "SelLength" _ + , "SelStart" _ + , "Seltext" _ , "SpecialEffect" _ , "SubType" _ , "TabIndex" _ @@ -995,65 +1028,65 @@ Dim vFullPropertiesList() As Variant Dim vPropertiesMatrix(25) As Variant Select Case _ParentType Case CTLPARENTISFORM, CTLPARENTISSUBFORM - vPropertiesMatrix(acCheckBox) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,31,32,36,37,38,39,40,42,43,44,45) - vPropertiesMatrix(acComboBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,27,28,31,32,33,34,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,9,10,11,12,13,14,15,16,17,27,28,31,37,38,39,40,42,45) - vPropertiesMatrix(acCurrencyField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,37,38,39,40,42,44,45) - vPropertiesMatrix(acDateField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,37,38,39,40,41,44,45) + vPropertiesMatrix(acCheckBox) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,31,32,39,40,41,42,43,45,46,47,48) + vPropertiesMatrix(acComboBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,27,28,31,32,33,34,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,31,40,41,42,43,45,47,48) + vPropertiesMatrix(acCurrencyField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,40,41,42,43,45,47,48) + vPropertiesMatrix(acDateField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,40,41,42,43,44,47,48) vPropertiesMatrix(acFixedLine) = Array() - vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,31,37,40,42,45) - vPropertiesMatrix(acFormattedField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acGridControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,27,28,31,37,38,39,40,45) - vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,31,37,40,45) - vPropertiesMatrix(acHiddenControl) = Array(7,27,28,31,37,40,44,45) - vPropertiesMatrix(acImageButton) = Array(0,1,2,6,7,10,27,28,31,37,38,39,40,45) - vPropertiesMatrix(acImageControl) = Array(0,1,2,5,6,7,10,25,27,28,31,32,37,38,39,40,45) - vPropertiesMatrix(acListBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,31,32,33,34,35,37,38,39,40,42,44,45) - vPropertiesMatrix(acNavigationBar) = Array(0,2,6,7,10,11,12,13,14,15,16,17,27,28,31,37,38,39,40,45) - vPropertiesMatrix(acNumericField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,37,38,39,40,42,44,45) - vPropertiesMatrix(acPatternField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,37,38,39,40,41,42,44,45) + vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,31,40,43,45,48) + vPropertiesMatrix(acFormattedField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acGridControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,27,28,31,40,41,42,43,48) + vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,31,40,43,48) + vPropertiesMatrix(acHiddenControl) = Array(7,27,28,31,40,43,47,48) + vPropertiesMatrix(acImageButton) = Array(0,1,2,6,7,10,27,28,31,40,41,42,43,48) + vPropertiesMatrix(acImageControl) = Array(0,1,2,5,6,7,10,25,27,28,31,32,40,41,42,43,48) + vPropertiesMatrix(acListBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,31,32,33,34,35,40,41,42,43,45,47,48) + vPropertiesMatrix(acNavigationBar) = Array(0,2,6,7,10,11,12,13,14,15,16,17,27,28,31,40,41,42,43,48) + vPropertiesMatrix(acNumericField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,40,41,42,43,45,47,48) + vPropertiesMatrix(acPatternField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,36,37,38,40,41,42,43,44,45,47,48) vPropertiesMatrix(acProgressBar) = Array() - vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,31,32,36,37,38,39,40,42,44,45) - vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,31,37,38,39,40,44,45) - vPropertiesMatrix(acSpinButton) = Array(0,1,2,6,7,9,10,27,28,31,37,38,39,40,44,45) - vPropertiesMatrix(0) = Array(7,18,21,22,27,28,31,37) - vPropertiesMatrix(acTextField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acTimeField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,37,38,39,40,41,42,44,45) + vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,31,32,39,40,41,42,43,45,47,48) + vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,31,40,41,42,43,47,48) + vPropertiesMatrix(acSpinButton) = Array(0,1,2,6,7,9,10,27,28,31,40,41,42,43,47,48) + vPropertiesMatrix(0) = Array(7,18,21,22,27,28,31,40) + vPropertiesMatrix(acTextField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,36,37,38,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acTimeField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,40,41,42,43,44,45,47,48) Case CTLPARENTISGROUP ' To be duplicated from above !!! - vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,31,32,36,37,38,39,40,42,44,45) + vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,31,32,39,40,41,42,43,45,47,48) Case CTLPARENTISGRID - vPropertiesMatrix(acCheckBox) = Array(4,5,6,7,9,10,27,28,31,32,36,37,40,42,43,44) - vPropertiesMatrix(acComboBox) = Array(4,5,6,7,9,10,20,23,24,25,27,28,31,32,33,34,37,40,41,42,44) - vPropertiesMatrix(acCurrencyField) = Array(4,5,6,7,9,10,25,27,28,31,32,37,40,42,44) - vPropertiesMatrix(acDateField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,37,40,41,42,44) - vPropertiesMatrix(acFormattedField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,37,40,41,42,44) - vPropertiesMatrix(acListBox) = Array(4,5,6,7,9,10,20,23,24,25,26,27,28,31,32,33,34,35,37,40,42,44) - vPropertiesMatrix(acNumericField) = Array(4,5,6,7,9,10,25,27,28,31,32,37,40,42,44) - vPropertiesMatrix(acPatternField) = Array(4,5,6,7,9,10,25,27,28,31,32,37,40,41,42,44) - vPropertiesMatrix(acTextField) = Array(4,5,6,7,9,10,25,27,28,31,32,37,40,41,42,44) - vPropertiesMatrix(acTimeField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,37,40,41,42,44) + vPropertiesMatrix(acCheckBox) = Array(4,5,6,7,9,10,27,28,31,32,39,40,43,45,46,47) + vPropertiesMatrix(acComboBox) = Array(4,5,6,7,9,10,20,23,24,25,27,28,31,32,33,34,40,43,44,45,47) + vPropertiesMatrix(acCurrencyField) = Array(4,5,6,7,9,10,25,27,28,31,32,40,43,45,47) + vPropertiesMatrix(acDateField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,40,43,44,45,47) + vPropertiesMatrix(acFormattedField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,40,43,44,45,47) + vPropertiesMatrix(acListBox) = Array(4,5,6,7,9,10,20,23,24,25,26,27,28,31,32,33,34,35,40,43,45,47) + vPropertiesMatrix(acNumericField) = Array(4,5,6,7,9,10,25,27,28,31,32,40,43,45,47) + vPropertiesMatrix(acPatternField) = Array(4,5,6,7,9,10,25,27,28,31,32,36,37,38,40,43,44,45,47) + vPropertiesMatrix(acTextField) = Array(4,5,6,7,9,10,25,27,28,31,32,36,37,38,40,43,44,45,47) + vPropertiesMatrix(acTimeField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,40,43,44,45,47) Case CTLPARENTISDIALOG - vPropertiesMatrix(acCheckBox) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,36,37,38,39,40,42,43,44,45) - vPropertiesMatrix(acComboBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,27,28,30,31,33,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,30,31,37,38,39,40,42,45) - vPropertiesMatrix(acCurrencyField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,42,44,45) - vPropertiesMatrix(acDateField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acFixedLine) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,37,38,40,45) - vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,37,38,39,40,42,45) - vPropertiesMatrix(acFormattedField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,37,38,40,45) - vPropertiesMatrix(acImageControl) = Array(0,1,2,6,7,10,27,28,30,31,37,38,39,40,45) - vPropertiesMatrix(acListBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,30,31,33,35,37,38,39,40,42,44,45) - vPropertiesMatrix(acNumericField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,42,44,45) - vPropertiesMatrix(acPatternField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acProgressBar) = Array(0,1,2,6,7,10,27,28,30,31,37,38,40,44,45) - vPropertiesMatrix(acRadioButton) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,30,31,36,37,38,39,40,42,44,45) - vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,31,37,38,39,40,44,45) - vPropertiesMatrix(acTextField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,41,42,44,45) - vPropertiesMatrix(acTimeField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,37,38,39,40,41,42,44,45) + vPropertiesMatrix(acCheckBox) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,39,40,41,42,43,45,46,47,48) + vPropertiesMatrix(acComboBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,27,28,30,31,33,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,30,31,40,41,42,43,45,48) + vPropertiesMatrix(acCurrencyField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,40,41,42,43,45,47,48) + vPropertiesMatrix(acDateField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acFixedLine) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,40,41,43,48) + vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,40,41,42,43,45,48) + vPropertiesMatrix(acFormattedField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,40,41,43,48) + vPropertiesMatrix(acImageControl) = Array(0,1,2,6,7,10,27,28,30,31,40,41,42,43,48) + vPropertiesMatrix(acListBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,30,31,33,35,40,41,42,43,45,47,48) + vPropertiesMatrix(acNumericField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,40,41,42,43,45,47,48) + vPropertiesMatrix(acPatternField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,36,37,38,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acProgressBar) = Array(0,1,2,6,7,10,27,28,30,31,40,41,43,47,48) + vPropertiesMatrix(acRadioButton) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,30,31,39,40,41,42,43,45,47,48) + vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,31,40,41,42,43,47,48) + vPropertiesMatrix(acTextField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,36,37,38,40,41,42,43,44,45,47,48) + vPropertiesMatrix(acTimeField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,40,41,42,43,44,45,47,48) End Select Dim vProperties() As Variant, i As Integer, iIndex As Integer @@ -1097,6 +1130,7 @@ Dim vListboxValue As Variant, vListSource, bSelected() As Boolean, bListboxBound Dim vGet As Variant, vDate As Variant Dim ofSubForm As Object Dim vFormats() As Variant +Dim vSelection As Variant, sSelectedText As String If Not hasProperty(psProperty) Then Goto Trace_Error @@ -1121,7 +1155,7 @@ Dim vFormats() As Variant If Utils._hasUNOProperty(ControlModel, "DefaultButton") Then _PropertyGet = ControlModel.DefaultButton Case UCase("DefaultValue") Select Case _SubType - Case CTLCHECKBOX, CTLCOMMANDBUTTON, CTLRADIOBUTTON + Case CTLCHECKBOX, CTLRADIOBUTTON If Utils._hasUNOProperty(ControlModel, "DefaultState") Then _PropertyGet = ControlModel.DefaultState Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD If Utils._hasUNOProperty(ControlModel, "DefaultText") Then _PropertyGet = ControlModel.DefaultText @@ -1188,10 +1222,15 @@ Dim vFormats() As Variant If Utils._hasUNOProperty(ControlModel, "TextColor") Then _PropertyGet = ControlModel.TextColor Case UCase("Form") Set ofSubForm = New SubForm ' Start building the SUBFORM object - Set ofSubForm.DatabaseForm = ControlModel - ofSubForm._Name = _Name - ofSubForm._Shortcut = _Shortcut & ".Form" - ofSubForm.ParentComponent = _FormComponent + With ofSubForm + Set ._This = ofSubForm + Set .DatabaseForm = ControlModel + ._Name = _Name + ._Shortcut = _Shortcut & ".Form" + .ParentComponent = _FormComponent + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With set _PropertyGet = ofSubForm Case UCase("Format") vFormats = _Formats(_Subtype) @@ -1332,6 +1371,34 @@ Dim vFormats() As Variant If IsMissing(pvIndex) Then _PropertyGet = bSelected Else _PropertyGet = bSelected(pvIndex) End If End If + Case UCase("SelLength") + If Utils._hasUNOProperty(ControlView, "Selection") Then + vSelection = ControlView.getSelection() + If vSelection.Max >= vSelection.Min Then + _PropertyGet = vSelection.Max - vSelection.Min + Else + _PropertyGet = 0 ' probably control does not have focus + End If + Else + _PropertyGet = 0 + End If + Case UCase("SelStart") + If Utils._hasUNOProperty(ControlView, "Selection") Then + vSelection = ControlView.getSelection() + If vSelection.Max >= vSelection.Min Then + _PropertyGet = vSelection.Min + 1 + Else + _PropertyGet = 1 ' probably control does not have focus + End If + Else + _PropertyGet = 1 + End If + Case UCase("SelText") + If Utils._hasUNOProperty(ControlView, "SelectedText") Then + _PropertyGet = ControlView.getSelectedText() + Else + _PropertyGet = "" + End If Case UCase("SpecialEffect") If Utils._hasUNOProperty(ControlModel, "VisualEffect") Then _PropertyGet = ControlModel.VisualEffect Case UCase("SubType") @@ -1381,6 +1448,11 @@ Dim vFormats() As Variant Select Case _SubType Case CTLCHECKBOX If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ControlModel.State + Case CTLCOMMANDBUTTON + vGet = False + If Utils._hasUNOProperty(ControlModel, "Toggle") Then + If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ( ControlModel.State = 1 ) + End If Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD If Utils._hasUNOProperty(ControlModel, "Text") Then vGet = ControlModel.Text Case CTLCURRENCYFIELD @@ -1514,6 +1586,7 @@ Dim odbDatabase As Object, vNames() As Variant, bFound As Boolean, sName As Stri Dim bMultiSelect As Boolean, iCount As Integer, iSelectedItems() As Integer, lListCount As Long, bSelected() As Boolean Dim vItemList() As Variant, vFormats() As Variant Dim oStruct As Object, sValue As String +Dim vSelection As Variant, sText As String, lStart As long _PropertySet = True Select Case UCase(_A2B_.CalledSub) @@ -1749,7 +1822,7 @@ Dim oStruct As Object, sValue As String Case com.sun.star.form.ListSourceType.QUERY _ , com.sun.star.form.ListSourceType.TABLE _ , com.sun.star.form.ListSourceType.TABLEFIELDS - Set odbDatabase = Application._CurrentDb() + Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry) If ControlModel.ListSourceType = com.sun.star.form.ListSourceType.QUERY Then vNames = odbDatabase.Connection.getQueries.GetElementNames _ Else vNames = odbDatabase.Connection.getTables.GetElementNames bFound = False ' Check existence of table or query and find its correct (case-sensitive) name @@ -1764,7 +1837,8 @@ Dim oStruct As Object, sValue As String If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = sName Else ControlModel.ListSource = Array(sName) ControlModel.refresh() Case com.sun.star.form.ListSourceType.SQL - If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = Utils._ReplaceSquareBrackets(pvValue) Else ControlModel.ListSource = Array(Utils._ReplaceSquareBrackets(pvValue)) + Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = odbDatabase._ReplaceSquareBrackets(pvValue) Else ControlModel.ListSource = Array(odbDatabase._ReplaceSquareBrackets(pvValue)) ControlModel.refresh() Case com.sun.star.form.ListSourceType.VALUELIST ' Forbidden for COMBOBOX ! If _SubType = CTLCOMBOBOX Then Goto Trace_Error @@ -1862,6 +1936,35 @@ Dim oStruct As Object, sValue As String ControlModel.SelectedItems = Array() End If End If + Case UCase("SelLength") + If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 0 Then Goto Trace_Error_Value + vSelection = ControlView.getSelection() + vSelection.Max = vSelection.Min + pvValue + ControlView.setSelection(vSelection) + Case UCase("SelStart") + If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value + If pvValue < 1 Or pvValue > Len(ControlModel.Text) + 1 Then Goto Trace_Error_Value + vSelection = ControlView.getSelection() + vSelection.Min = pvValue - 1 + vSelection.Max = pvValue - 1 ' Also reset length to 0 + ControlView.setSelection(vSelection) + Case UCase("SelText") + If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error + If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Len(pvValue) > 0 Then + vSelection = ControlView.getSelection() + sText = ControlModel.Text + lStart = InStr(1, sText, pvValue, 0) ' Case sensitive ! + If lStart > 0 Then + vSelection.Min = lStart - 1 + vSelection.Max = lStart + Len(pvValue) - 1 + ControlView.setSelection(vSelection) + End If + End If Case UCase("SpecialEffect") If Not Utils._hasUNOProperty(ControlModel, "VisualEffect") Then Goto Trace_Error If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value @@ -1897,6 +2000,11 @@ Dim oStruct As Object, sValue As String If VarType(pvValue) = vbBoolean Then pvValue = Iif(pvValue, 1, 0) If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know ControlModel.State = pvValue + Case CTLCOMMANDBUTTON + If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error + If Not Utils._hasUNOProperty(ControlModel, "Toggle") Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value + If pvValue Then ControlModel.State = 1 Else ControlModel.State = 0 Case CTLCOMBOBOX If Not Utils._hasUNOProperty(ControlModel, "Text") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _ Then Goto Trace_Error @@ -2043,7 +2151,7 @@ Error_Function: TraceError(TRACEABORT, Err, "Control._PropertySet", Erl) _PropertySet = False GoTo Exit_Function -End Function ' _PropertySet V1.0.0 +End Function ' _PropertySet V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS PROPERTY SETs --- @@ -2155,6 +2263,18 @@ Property Set Selected(ByVal pvValue As Variant) ' , ByVal Optional pvIndex Call _PropertySet("Selected", pvValue) End Property ' Selected (set) +Property Set SelLength(ByVal pvValue As Variant) + Call _PropertySet("SelLength", pvValue) +End Property ' SelLength (set) + +Property Set SelStart(ByVal pvValue As Variant) + Call _PropertySet("SelStart", pvValue) +End Property ' SelStart (set) + +Property Set SelText(ByVal pvValue As Variant) + Call _PropertySet("SelText", pvValue) +End Property ' SelText (set) + Property Set SpecialEffect(ByVal pvValue As Variant) Call _PropertySet("SpecialEffect", pvValue) End Property ' SpecialEffect (set) diff --git a/wizards/source/access2base/DataDef.xba b/wizards/source/access2base/DataDef.xba index 2de30f866bff..4236548de25d 100644 --- a/wizards/source/access2base/DataDef.xba +++ b/wizards/source/access2base/DataDef.xba @@ -16,8 +16,13 @@ REM ---------------------------------------------------------------------------- Private _Type As String ' Must be TABLEDEF or QUERYDEF Private _Name As String +Private _ParentDatabase As Object +Private _ReadOnly As Boolean Private Table As Object ' com.sun.star.sdb.dbaccess.ODBTable Private Query As Object ' com.sun.star.sdb.dbaccess.OQuery +Private TableDescriptor As Object ' com.sun.star.sdb.dbaccess.ODBTable +Private TableFieldsCount As Integer +Private TableKeysCount As Integer REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- @@ -25,8 +30,13 @@ REM ---------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = "" _Name = "" + Set _ParentDatabase = Nothing + _ReadOnly = False Set Table = Nothing Set Query = Nothing + Set TableDescriptor = Nothing + TableFieldsCount = 0 + TableKeysCount = 0 End Sub ' Constructor REM ----------------------------------------------------------------------------------------------------------------------- @@ -55,14 +65,123 @@ Property Let SQL(ByVal pvValue As Variant) End Property ' SQL (set) REM ----------------------------------------------------------------------------------------------------------------------- -Property Get pType() As Integer +Public Function pType() As Integer pType = _PropertyGet("Type") -End Property ' Type (get) +End Function ' Type (get) REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CreateField(ByVal Optional pvFieldName As Variant _ + , ByVal optional pvType As Variant _ + , ByVal optional pvSize As Variant _ + , ByVal optional pvAttributes As variant _ + ) As Object +'Return a Field object +Const cstThisSub = "TableDef.CreateField" + Utils._SetCalledSub(cstThisSub) + + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim oTable As Object, oNewField As Object, oKeys As Object, oPrimaryKey As Object, oColumn As Object +Const cstMaxKeyLength = 30 + + CreateField = Nothing + If _ParentDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If IsMissing(pvFieldName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvFieldName, 1, vbString) Then Goto Exit_Function + If pvFieldName = "" Then Call _TraceArguments() + If IsMissing(pvType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric( _ + dbInteger, dbLong, dbBigInt, dbFloat, vbSingle, dbDouble _ + , dbNumeric, dbDecimal, dbText, dbChar, dbMemo _ + , dbDate, dbTime, dbTimeStamp _ + , dbBinary, dbVarBinary, dbLongBinary, dbBoolean _ + )) Then Goto Exit_Function + If IsMissing(pvSize) Then pvSize = 0 + If pvSize < 0 Then pvSize = 0 + If Not Utils._CheckArgument(pvSize, 1, Utils._AddNumeric()) Then Goto Exit_Function + If IsMissing(pvAttributes) Then pvAttributes = 0 + If Not Utils._CheckArgument(pvAttributes, 1, Utils._AddNumeric(), Array(0, dbAutoIncrField)) Then Goto Exit_Function + + If _Type <> OBJTABLEDEF Then Goto Error_NotApplicable + If IsNull(Table) And IsNull(TableDescriptor) Then Goto Error_NotApplicable + + If _ReadOnly Then Goto Error_NoUpdate + + Set oNewField = New Field + With oNewField + ._Name = pvFieldName + ._ParentName = _Name + ._ParentType = OBJTABLEDEF + If IsNull(Table) Then Set oTable = TableDescriptor Else Set oTable = Table + Set .Column = oTable.Columns.createDataDescriptor() + End With + With oNewField.Column + .Name = pvFieldName + Select Case pvType + Case dbInteger : .Type = com.sun.star.sdbc.DataType.TINYINT + Case dbLong : .Type = com.sun.star.sdbc.DataType.INTEGER + Case dbBigInt : .Type = com.sun.star.sdbc.DataType.BIGINT + Case dbFloat : .Type = com.sun.star.sdbc.DataType.FLOAT + Case dbSingle : .Type = com.sun.star.sdbc.DataType.REAL + Case dbDouble : .Type = com.sun.star.sdbc.DataType.DOUBLE + Case dbNumeric, dbCurrency : .Type = com.sun.star.sdbc.DataType.NUMERIC + Case dbDecimal : .Type = com.sun.star.sdbc.DataType.DECIMAL + Case dbText : .Type = com.sun.star.sdbc.DataType.CHAR + Case dbChar : .Type = com.sun.star.sdbc.DataType.VARCHAR + Case dbMemo : .Type = com.sun.star.sdbc.DataType.LONGVARCHAR + Case dbDate : .Type = com.sun.star.sdbc.DataType.DATE + Case dbTime : .Type = com.sun.star.sdbc.DataType.TIME + Case dbTimeStamp : .Type = com.sun.star.sdbc.DataType.TIMESTAMP + Case dbBinary : .Type = com.sun.star.sdbc.DataType.BINARY + Case dbVarBinary : .Type = com.sun.star.sdbc.DataType.VARBINARY + Case dbLongBinary : .Type = com.sun.star.sdbc.DataType.LONGVARBINARY + Case dbBoolean : .Type = com.sun.star.sdbc.DataType.BOOLEAN + End Select + .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 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 + Set oKeys = oTable.Keys + Set oPrimaryKey = oKeys.createDataDescriptor() + Set oColumn = oPrimaryKey.Columns.createDataDescriptor() + oColumn.Name = pvFieldName + oColumn.IsAutoIncrement = True + oPrimaryKey.Columns.appendByDescriptor(oColumn) + oPrimaryKey.Name = Left("PK_" & Join(Split(oNewField._ParentName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength) + oKeys.appendByDescriptor(oPrimaryKey) + .IsAutoIncrement = True + .IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS + oColumn.dispose() + Else + .IsAutoIncrement = False + End If + End With + oTable.Columns.appendByDescriptor(oNewfield.Column) + + Set CreateField = oNewField + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Sequence: + TraceError(TRACEFATAL, ERRFIELDCREATION, Utils._CalledSub(), 0, 1, pvFieldName) + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' CreateField V1.1.0 + REM ----------------------------------------------------------------------------------------------------------------------- Public Function Execute(ByVal Optional pvOptions As Variant) As Boolean 'Execute a stored query. The query must be an ACTION query. @@ -81,19 +200,18 @@ Const cstNull = -1 End If 'Check action query -Dim oDatabase As Object, oStatement As Object, vResult As Variant +Dim oStatement As Object, vResult As Variant Dim iType As Integer, sSql As String iType = pType If ( (iType And DBQAction) = 0 ) And ( (iType And DBQDDL) = 0 ) Then Goto Trace_Action 'Execute action query - Set oDatabase = Application._CurrentDb() - Set oStatement = oDatabase.Connection.createStatement() + Set oStatement = _ParentDatabase.Connection.createStatement() sSql = Query.Command If pvOptions = dbSQLPassThrough Then oStatement.EscapeProcessing = False _ - Else oStatement.EscapeProcessing = True + Else oStatement.EscapeProcessing = Query.EscapeProcessing On Local Error Goto SQL_Error - vResult = oStatement.executeUpdate(Utils._ReplaceSquareBrackets(sSql)) + vResult = oStatement.executeUpdate(_ParentDatabase._ReplaceSquareBrackets(sSql)) On Local Error Goto Error_Function Execute = True @@ -113,7 +231,7 @@ SQL_Error: Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function -End Function ' Execute +End Function ' Execute V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Fields(ByVal Optional pvIndex As variant) As Object @@ -139,6 +257,7 @@ Dim i As Integer, bFound As Boolean, oFields As Object oObject._CollType = COLLFIELDS oObject._ParentType = _Type oObject._ParentName = _Name + Set oObject._ParentDatabase = _ParentDatabase oObject._Count = UBound(sObjects) + 1 Goto Exit_Function Case VarType(pvIndex) = vbString @@ -162,6 +281,7 @@ Dim i As Integer, bFound As Boolean, oFields As Object Set oObject.Column = oFields.getByName(sObjectName) oObject._ParentName = _Name oObject._ParentType = _Type + Set oObject._ParentDatabase = _ParentDatabase Exit_Function: Set Fields = oObject @@ -172,7 +292,7 @@ Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Trace_NotFound: - TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Field", pvIndex)) + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) @@ -207,14 +327,14 @@ End Function ' hasProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenRecordset(ByVal Optional pvType As Variant, ByVal Optional pvOptions As Variant, ByVal Optional pvLockEdit As Variant) As Object -'Return a Recordset object based on current tabledef object +'Return a Recordset object based on current table- or querydef object Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) & ".OpenRecordset" Utils._SetCalledSub(cstThisSub) Const cstNull = -1 -Dim lCommandType As Long, sCommand As String, oObject As Object -Dim odbDatabase As Object +Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As Boolean + Set oObject = Nothing If IsMissing(pvType) Then pvType = cstNull @@ -239,6 +359,7 @@ Dim odbDatabase As Object Case OBJQUERYDEF lCommandType = com.sun.star.sdb.CommandType.QUERY sCommand = _Name + If pvOptions = dbSQLPassThrough Then bPassThrough = True Else bPassThrough = Not Query.EscapeProcessing End Select Set oObject = New Recordset @@ -248,12 +369,12 @@ Dim odbDatabase As Object ._ParentName = _Name ._ParentType = _Type ._ForwardOnly = ( pvType = dbOpenForwardOnly ) - ._PassThrough = ( pvOptions = dbSQLPassThrough ) - ._ReadOnly = ( pvLockEdit = dbReadOnly ) + ._PassThrough = bPassThrough + ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly ) + Set ._ParentDatabase = _ParentDatabase Call ._Initialize() End With - Set odbDatabase = Application._CurrentDb() - With odbDatabase + With _ParentDatabase .RecordsetMax = .RecordsetMax + 1 oObject._Name = Format(.RecordsetMax, "0000000") .RecordsetsColl.Add(oObject, UCase(oObject._Name)) @@ -270,7 +391,7 @@ Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) Set oObject = Nothing GoTo Exit_Function -End Function ' OpenRecordset +End Function ' OpenRecordset V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Properties(ByVal Optional pvIndex As Variant) As Variant @@ -290,6 +411,7 @@ Dim cstThisSub As String vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If + Set vProperty._ParentDatabase = _ParentDatabase Exit_Function: Set Properties = vProperty @@ -325,6 +447,7 @@ Dim cstThisSub As String Utils._SetCalledSub(cstThisSub & ".get" & psProperty) Dim vEMPTY As Variant, sSql As String, sVerb As String, iType As Integer _PropertyGet = vEMPTY + If Not hasProperty(psProperty) Then Goto Trace_Error Select Case UCase(psProperty) Case UCase("Name") @@ -361,7 +484,7 @@ Exit_Function: Utils._ResetCalledSub(cstThisSub & ".get" & psProperty) Exit Function Trace_Error: - TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) _PropertyGet = vEMPTY Goto Exit_Function Error_Function: @@ -390,6 +513,8 @@ Dim iArgNr As Integer End Select If Not hasProperty(psProperty) Then Goto Trace_Error + + If _ReadOnly Then Goto Error_NoUpdate Select Case UCase(psProperty) Case UCase("SQL") @@ -410,6 +535,9 @@ Trace_Error_Value: TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) _PropertySet = False Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub & "._PropertySet", Erl) _PropertySet = False diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba index b09b7dd5eb5b..cbfec7095d12 100644 --- a/wizards/source/access2base/Database.xba +++ b/wizards/source/access2base/Database.xba @@ -15,17 +15,16 @@ REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- Private _Type As String ' Must be DATABASE -Private _Standalone As Boolean +Private _This As Object ' Workaround for absence of This builtin function +Private _DbConnect As Integer ' DBCONNECTxxx constants Private Title As String -Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument -Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper +Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj +Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper or com.sun.star.sdbc.XConnection Private URL As String +Private _ReadOnly As Boolean Private MetaData As Object ' interface XDatabaseMetaData Private Form As Object ' com.sun.star.form.XForm -Private FormName As String ' name of standalone form -Private FindRecord As Object -Private StatusBar As Object -Private Dialogs As Object ' Collection +Private FormName As String Private RecordsetMax As Integer Private RecordsetsColl As Object ' Collection of active recordsets @@ -34,17 +33,16 @@ REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJDATABASE - _Standalone = False + Set _This = Nothing + _DbConnect = 0 Title = "" Set Document = Nothing Set Connection = Nothing URL = "" + _ReadOnly = False Set MetaData = Nothing Set Form = Nothing FormName = "" - Set FindRecord = Nothing - Set StatusBar = Nothing - Set Dialogs = New Collection RecordsetMax = 0 Set RecordsetsColl = New Collection End Sub ' Constructor @@ -65,6 +63,31 @@ REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- +Public Function mClose() As Variant +' Close the form + +If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Database.Close" + Utils._SetCalledSub(cstThisSub) + mClose = False + If _DbConnect <> DBCONNECTANY Then Goto Error_NotApplicable + + Connection.close() + Connection.dispose() + mClose = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) + GoTo Exit_Function +End Function ' (m)Close + +REM ----------------------------------------------------------------------------------------------------------------------- Public Sub CloseAllRecordsets() ' Clean all recordsets for housekeeping @@ -94,12 +117,12 @@ Const cstThisSub = "Database.CreateQueryDef" Utils._SetCalledSub(cstThisSub) Const cstNull = -1 -Dim oQuery As Object, oQueries As Object +Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String If _ErrorHandler() Then On Local Error Goto Error_Function Set CreateQueryDef = Nothing - If _Standalone() Then Goto Error_Standalone + If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable If IsMissing(pvQueryName) Then Call _TraceArguments() If IsMissing(pvSql) Then Call _TraceArguments() If IsMissing(pvOption) Then pvOption = cstNull @@ -110,17 +133,23 @@ Dim oQuery As Object, oQueries As Object If pvSql = "" Then Call _TraceArguments() If Not Utils._CheckArgument(pvOption, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + If _ReadOnly Then Goto Error_NoUpdate + Set oQuery = CreateUnoService("com.sun.star.sdb.QueryDefinition") oQuery.rename(pvQueryName) - oQuery.Command = Utils._ReplaceSquareBrackets(pvSql) + oQuery.Command = _ReplaceSquareBrackets(pvSql) oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough ) Set oQueries = Document.DataSource.getQueryDefinitions() With oQueries - If .hasByName(pvQueryName) Then - TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, pvQueryName) - .removeByName(pvQueryName) - End If + For i = 0 To .getCount() - 1 + sQueryName = .getByIndex(i).Name + If UCase(sQueryName) = UCase(pvQueryName) Then + TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, sQueryName) + .removeByName(sQueryName) + Exit For + End If + Next i .insertByName(pvQueryName, oQuery) End With Set CreateQueryDef = QueryDefs(pvQueryName) @@ -128,13 +157,229 @@ Dim oQuery As Object, oQueries As Object Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function -Error_Standalone: - TraceError(TRACEFATAL, ERRSTANDALONE, Utils._CalledSub(), 0) +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CreateQueryDef V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CreateTableDef(ByVal Optional pvTableName As Variant) As Object +'Return a (new/empty) TableDef object +Const cstThisSub = "Database.CreateTableDef" + Utils._SetCalledSub(cstThisSub) + +Dim oTable As Object, oTables As Object, sTables() As String +Dim i As Integer, sTableName As String, oNewTable As Object + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Set CreateTableDef = Nothing + If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If IsMissing(pvTableName) Then Call _TraceArguments() + + If Not Utils._CheckArgument(pvTableName, 1, vbString) Then Goto Exit_Function + If pvTableName = "" Then Call _TraceArguments() + + If _ReadOnly Then Goto Error_NoUpdate + + Set oTables = Connection.getTables + With oTables + sTables = .ElementNames() + ' Check existence of object and find its exact (case-sensitive) name + For i = 0 To UBound(sTables) + If UCase(pvTableName) = UCase(sTables(i)) Then + sTableName = sTables(i) + TraceError(TRACEWARNING, ERRTABLEDEFDELETED, Utils._CalledSub(), 0, False, sTableName) + .dropByName(sTableName) + Exit For + End If + Next i + Set oNewTable = New DataDef + oNewTable._Type = OBJTABLEDEF + oNewTable._Name = pvTableName + Set oNewTable._ParentDatabase = _This + Set oNewTable.TableDescriptor = .createDataDescriptor() + oNewTable.TableDescriptor.Name = pvTableName + End With + + Set CreateTabledef = oNewTable + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_NoUpdate: + TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function -End Function ' CreateQueryDef V0.9.5 +End Function ' CreateTableDef V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DAvg( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return average of scope +Const cstThisSub = "Database.DAvg" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DAvg = _DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DAvg + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DCount( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return # of occurrences of scope +Const cstThisSub = "Database.DCount" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DCount = _DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DCount + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DLookup( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + , ByVal Optional pvOrderClause As Variant _ + ) As Variant + +' Return a value within a table + 'Arguments: psExpr: an SQL expression + ' psDomain: a table- or queryname + ' pvCriteria: an optional WHERE clause + ' pcOrderClause: an optional order clause incl. "DESC" if relevant + 'Return: Value of the psExpr if found, else Null. + 'Author: inspired from Allen Browne. http://allenbrowne.com/ser-42.html + 'Examples: + ' 1. To find the last value, include DESC in the OrderClause, e.g.: + ' DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC") + ' 2. To find the lowest non-null value of a field, use the Criteria, e.g.: + ' DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname") + +Const cstThisSub = "Database.DLookup" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DLookup = _DFunction("", psExpr, psDomain _ + , Iif(IsMissing(pvCriteria), "", pvCriteria) _ + , Iif(IsMissing(pvOrderClause), "", pvOrderClause) _ + ) + Utils._ResetCalledSub(cstThisSub) +End Function ' DLookup + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMax( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return maximum of scope +Const cstThisSub = "Database.DMax" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMax = _DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMax + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DMin( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return minimum of scope +Const cstThisSub = "Database.DMin" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DMin = _DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DMin + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDev( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "Database.DStDev" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDev = _DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDev + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DStDevP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return standard deviation of scope +Const cstThisSub = "Database.DStDevP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DStDevP = _DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV ! + Utils._ResetCalledSub(cstThisSub) +End Function ' DStDevP + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DSum( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return sum of scope +Const cstThisSub = "Database.DSum" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DSum = _DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DSum + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVar( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "Database.DVar" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVar = _DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVar + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function DVarP( _ + ByVal Optional psExpr As String _ + , ByVal Optional psDomain As String _ + , ByVal Optional pvCriteria As Variant _ + ) As Variant +' Return variance of scope +Const cstThisSub = "Database.DVarP" + Utils._SetCalledSub(cstThisSub) + If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments() + DVarP = _DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") + Utils._ResetCalledSub(cstThisSub) +End Function ' DVarP REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant @@ -196,7 +441,7 @@ Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Obje Select Case True Case sSource = "SELECT" lCommandType = com.sun.star.sdb.CommandType.COMMAND - sCommand = Trim(Utils._ReplaceSquareBrackets(pvSource)) + sCommand = _ReplaceSquareBrackets(pvSource) Case Else sSource = UCase(Trim(pvSource)) REM Explore tables @@ -236,7 +481,8 @@ Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Obje ._ParentType = _Type ._ForwardOnly = ( pvType = dbOpenForwardOnly ) ._PassThrough = ( pvOptions = dbSQLPassThrough ) - ._ReadOnly = ( pvLockEdit = dbReadOnly ) + ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly ) + Set ._ParentDatabase = _This Call ._Initialize() RecordsetMax = RecordsetMax + 1 ._Name = Format(RecordsetMax, "0000000") @@ -254,9 +500,65 @@ Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Trace_NotFound: - TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Table/Query", pvSource)) + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE") & "/" & _GetLabel("QUERY"), pvSource)) + Goto Exit_Function +End Function ' OpenRecordset V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function OpenSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain a SELECT query +' pvOption can force pass through mode + + If _ErrorHandler() Then On Local Error Goto Error_Function + +Const cstThisSub = "Database.OpenSQL" + Utils._SetCalledSub(cstThisSub) + + OpenSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function + End If + If _DbConnect <> DBCONNECTBASE And _DbConnect <> DBCONNECTFORM Then Goto Error_NotApplicable + +Dim oURL As New com.sun.star.util.URL, oDispatch As Object +Dim vArgs(8) as New com.sun.star.beans.PropertyValue + + oURL.Complete = ".component:DB/DataSourceBrowser" + oDispatch = StarDesktop.queryDispatch(oURL, "_Blank", 8) + + vArgs(0).Name = "ActiveConnection" : vArgs(0).Value = Connection + vArgs(1).Name = "CommandType" : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND + vArgs(2).Name = "Command" : vArgs(2).Value = _ReplaceSquareBrackets(pvSQL) + vArgs(3).Name = "ShowMenu" : vArgs(3).Value = True + vArgs(4).Name = "ShowTreeView" : vArgs(4).Value = False + vArgs(5).Name = "ShowTreeViewButton" : vArgs(5).Value = False + vArgs(6).Name = "Filter" : vArgs(6).Value = "" + vArgs(7).Name = "ApplyFilter" : vArgs(7).Value = False + vArgs(8).Name = "EscapeProcessing" : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough )) + + oDispatch.dispatch(oURL, vArgs) + OpenSQL = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "OpenSQL", Erl) + GoTo Exit_Function +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function -End Function ' OpenRecordset V0.9.5 +End Function ' OpenSQL V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Properties(ByVal Optional pvIndex As Variant) As Variant @@ -274,6 +576,7 @@ Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String vProperty = PropertiesGet._Properties(sObject, "", vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If + Set vProperty._ParentDatabase = _This Exit_Function: Set Properties = vProperty @@ -282,21 +585,21 @@ Exit_Function: End Function ' Properties REM ----------------------------------------------------------------------------------------------------------------------- -Public Function QueryDefs(ByVal Optional pvIndex As variant) As Object +Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object ' Collect all Queries in the database -' Check when standalone <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +' pbCheck unpublished If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Database.QueryDefs") + If IsMissing(pbCheck) Then pbCheck = False - Set QueryDefs = Nothing +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oQueries As Object + Set oObject = Nothing If Not IsMissing(pvIndex) Then If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function End If -Dim sObjects() As String, sObjectName As String, oObject As Object -Dim i As Integer, bFound As Boolean, oQueries As Object - Set oQueries = Connection.getQueries sObjects = oQueries.ElementNames() Select Case True @@ -305,6 +608,7 @@ Dim i As Integer, bFound As Boolean, oQueries As Object oObject._CollType = COLLQUERYDEFS oObject._ParentType = OBJDATABASE oObject._ParentName = "" + Set oObject._ParentDatabase = _This oObject._Count = UBound(sObjects) + 1 Goto Exit_Function Case VarType(pvIndex) = vbString @@ -326,6 +630,8 @@ Dim i As Integer, bFound As Boolean, oQueries As Object Set oObject = New DataDef oObject._Type = OBJQUERYDEF oObject._Name = sObjectName + Set oObject._ParentDatabase = _This + oObject._readOnly = _ReadOnly Set oObject.Query = oQueries.getByName(sObjectName) Exit_Function: @@ -337,15 +643,15 @@ Error_Function: TraceError(TRACEABORT, Err, "Database.QueryDefs", Erl) GoTo Exit_Function Trace_NotFound: - TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Query", pvIndex)) + If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("QUERY"), pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) Goto Exit_Function -End Function ' QueryDefs V0.9.5 +End Function ' QueryDefs V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function Recordsets(ByVal Optional pvIndex As variant) As Object +Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object ' Collect all active recordsets If _ErrorHandler() Then On Local Error Goto Error_Function @@ -365,6 +671,7 @@ Dim i As Integer, bFound As Boolean, oTables As Object oObject._CollType = COLLRECORDSETS oObject._ParentType = OBJDATABASE oObject._ParentName = "" + Set oObject._ParentDatabase = _This oObject._Count = RecordsetsColl.Count Case VarType(pvIndex) = vbString bFound = _hasRecordset(pvIndex) @@ -384,7 +691,7 @@ Error_Function: TraceError(TRACEABORT, Err, "Database.Recordsets", Erl) GoTo Exit_Function Trace_NotFound: - TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Recordset", pvIndex)) + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("RECORDSET"), pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) @@ -392,21 +699,60 @@ Trace_IndexError: End Function ' Recordsets V0.9.5 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function TableDefs(ByVal Optional pvIndex As variant) As Object +Public Function RunSQL(Optional ByVal pvSQL As Variant _ + , Optional ByVal pvOption As Variant _ + ) As Boolean +' Return True if the execution of the SQL statement was successful +' SQL must contain an ACTION query + + If _ErrorHandler() Then On Local Error Goto Error_Function + + Utils._SetCalledSub("RunSQL") + + RunSQL = False + If IsMissing(pvSQL) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function +Const cstNull = -1 + If IsMissing(pvOption) Then + pvOption = cstNull + Else + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function + End If + +Dim oStatement As Object, vResult As Variant + Set oStatement = Connection.createStatement() + oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough ) + On Local Error Goto SQL_Error + vResult = oStatement.executeUpdate(_ReplaceSquareBrackets(pvSQL)) + On Local Error Goto Error_Function + RunSQL = True + +Exit_Function: + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, "RunSQL", Erl) + GoTo Exit_Function +SQL_Error: + TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) + Goto Exit_Function +End Function ' RunSQL V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object ' Collect all tables in the database -' Check when standalone <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +' pbCheck unpublished If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Database.TableDefs") + If IsMissing(pbCheck) Then pbCheck = False - Set TableDefs = Nothing +Dim sObjects() As String, sObjectName As String, oObject As Object +Dim i As Integer, bFound As Boolean, oTables As Object + Set oObject = Nothing If Not IsMissing(pvIndex) Then If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function End If -Dim sObjects() As String, sObjectName As String, oObject As Object -Dim i As Integer, bFound As Boolean, oTables As Object - Set oTables = Connection.getTables sObjects = oTables.ElementNames() Select Case True @@ -415,6 +761,7 @@ Dim i As Integer, bFound As Boolean, oTables As Object oObject._CollType = COLLTABLEDEFS oObject._ParentType = OBJDATABASE oObject._ParentName = "" + Set oObject._ParentDatabase = _This oObject._Count = UBound(sObjects) + 1 Goto Exit_Function Case VarType(pvIndex) = vbString @@ -436,6 +783,8 @@ Dim i As Integer, bFound As Boolean, oTables As Object Set oObject = New DataDef oObject._Type = OBJTABLEDEF oObject._Name = sObjectName + Set oObject._ParentDatabase = _This + oObject._ReadOnly = _ReadOnly Set oObject.Table = oTables.getByName(sObjectName) Exit_Function: @@ -447,32 +796,77 @@ Error_Function: TraceError(TRACEABORT, Err, "Database.TableDefs", Erl) GoTo Exit_Function Trace_NotFound: - TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Table", pvIndex)) + If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) Goto Exit_Function -End Function ' TableDefs V0.9.5 +End Function ' TableDefs V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- -Public Function _hasDialog(ByVal psName As String) As Boolean -' Return True if psName if in the collection of started dialogs - -Dim oDialog As Object - If _ErrorHandler() Then On Local Error Goto Error_Function - Set oDialog = Dialogs.Item(UCase(psName)) - _hasDialog = True +Private Function _DFunction(ByVal psFunction As String _ + , ByVal psExpr As String _ + , ByVal psDomain As String _ + , ByVal pvCriteria As Variant _ + , ByVal Optional pvOrderClause As Variant _ + ) As Variant + 'Arguments: psFunction an optional aggregate function + ' psExpr: an SQL expression [might contain an aggregate function] + ' psDomain: a table- or queryname + ' pvCriteria: an optional WHERE clause + ' pcOrderClause: an optional order clause incl. "DESC" if relevant + +If _ErrorHandler() Then On Local Error GoTo Error_Function + +Dim oResult As Object 'To retrieve the value to find. +Dim vResult As Variant 'Return value for function. +Dim sSql As String 'SQL statement. +Dim oStatement As Object 'For CreateStatement method +Dim sExpr As String 'For inclusion of aggregate function +Dim sTempField As String 'Random temporary field in SQL expression + + vResult = Null + + If psFunction = "" Then sExpr = "TOP 1 " & psExpr Else sExpr = UCase(psFunction) & "(" & psExpr & ")" + + Randomize 2^14-1 + sTempField = "TEMP" & Right("00000" & Int(100000 * Rnd), 5) + sSql = "SELECT " & sExpr & " AS [" & sTempField & "] FROM " & psDomain + If pvCriteria <> "" Then + sSql = sSql & " WHERE " & pvCriteria + End If + If pvOrderClause <> "" Then + sSql = sSql & " ORDER BY " & pvOrderClause + End If + + 'Lookup the value. + Set oStatement = Connection.createStatement() + With oStatement + .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY + .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY + .EscapeProcessing = False + sSql = _ReplaceSquareBrackets(sSql) 'Substitute [] by quote string + Set oResult = .executeQuery(sSql) + If Not IsNull(oResult) And Not IsEmpty(oResult) Then + If Not oResult.next() Then Goto Exit_Function + vResult = Utils._getResultSetColumnValue(oResult, 1) + End If + End With Exit_Function: - Exit Function -Error_Function: ' Item by key aborted - _hasDialog = False - GoTo Exit_Function -End Function ' _hasDialog V0.9.1 + 'Assign the returned value. + _DFunction = vResult + Set oResult = Nothing + Set oStatement = Nothing + Exit Function +Error_Function: + TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL) + Goto Exit_Function +End Function ' DFunction V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _hasRecordset(ByVal psName As String) As Boolean @@ -525,4 +919,30 @@ Error_Function: _PropertyGet = vEMPTY GoTo Exit_Function End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String +' Returns psSql after substitution of [] by quote character +' [] square brackets in (single) quoted strings not affected + +Dim sQuote As String 'RDBMS specific quote character +Dim vSubStrings() As Variant, i As Integer +Const cstSingleQuote = "'" + + sQuote = MetaData.IdentifierQuoteString + If sQuote = " " Then ' IdentifierQuoteString returns a space " " if identifier quoting is not supported. + _ReplaceSquareBrackets = Trim(psSql) + Exit Function + End If + vSubStrings() = Split(psSql, cstSingleQuote) + For i = 0 To UBound(vSubStrings) + If (i Mod 2) = 0 Then ' Only even substrings are parsed for square brackets + vSubStrings(i) = Join(Split(vSubStrings(i), "["), sQuote) + vSubStrings(i) = Join(Split(vSubStrings(i), "]"), sQuote) + End If + Next i + + _ReplaceSquareBrackets = Trim(Join(vSubStrings, cstSingleQuote)) + +End Function ' ReplaceSquareBrackets V1.1.0 </script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Dialog.xba b/wizards/source/access2base/Dialog.xba index 146e060d88eb..4d8bd03a0da1 100644 --- a/wizards/source/access2base/Dialog.xba +++ b/wizards/source/access2base/Dialog.xba @@ -288,7 +288,7 @@ Exit_Function: Utils._ResetCalledSub("Dialog.Controls") Exit Function Trace_Error: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , iArg) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(iArg, pvIndex)) Set Controls = Nothing Goto Exit_Function Trace_Error_NotOpen: @@ -420,12 +420,19 @@ Dim iArgNr As Integer If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function -Dim iArg As Integer ' Check arguments values +Dim iArg As Integer, iWrong As Integer ' Check arguments values iArg = 0 - If pvHeight < -1 Then iArg = 4 : If pvWidth < -1 Then iArg = 3 - If pvTop < -1 Then iArg = 2 : If pvLeft < -1 Then iArg = 1 + If pvHeight < -1 Then + iArg = 4 : iWrong = pvHeight + ElseIf pvWidth < -1 Then + iArg = 3 : iWrong = pvWidth + ElseIf pvTop < -1 Then + iArg = 2 : iWrong = pvTop + ElseIf pvLeft < -1 Then + iArg = 1 : iWrong = pvLeft + End If If iArg > 0 Then - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, iArgNr + iArg) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong)) Goto Exit_Function End If @@ -461,7 +468,7 @@ Public Function Start() As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Dialog.Start") -Dim oStart As Object, oDatabase As Object +Dim oStart As Object Start = False If IsNull(_Dialog) Then Goto Error_Start If Not IsNull(UnoDialog) Then Goto Error_Yet_Started @@ -471,9 +478,8 @@ Dim oStart As Object, oDatabase As Object Else Start = True Set UnoDialog = oStart - Set oDatabase = Application._CurrentDb() - With oDatabase - If ._hasDialog(_Name) Then .Dialogs.Remove(_Name) ' Inserted to solve errors, when aborts between start and terminate + With _A2B_ + If Application._hasDialog(_Name) Then .Dialogs.Remove(_Name) ' Inserted to solve errors, when aborts between start and terminate .Dialogs.Add(UnoDialog, UCase(_Name)) End With End If @@ -504,7 +510,7 @@ If _ErrorHandler() Then On Local Error Goto Error_Function If IsNull(UnoDialog) Then Goto Error_Not_Started UnoDialog.Dispose() Set UnoDialog = Nothing - Application._CurrentDb().Dialogs.Remove(_Name) + _A2B_.Dialogs.Remove(_Name) Terminate = True Exit_Function: @@ -546,7 +552,7 @@ Private Function _PropertyGet(ByVal psProperty As String) As Variant Utils._SetCalledSub("Dialog.get" & psProperty) 'Execute -Dim oDatabase As Object, vEMPTY As Variant +Dim vEMPTY As Variant _PropertyGet = vEMPTY Select Case UCase(psProperty) @@ -560,8 +566,7 @@ Dim oDatabase As Object, vEMPTY As Variant Case UCase("Height") _PropertyGet = UnoDialog.getPosSize().Height Case UCase("IsLoaded") - Set oDatabase = Application._CurrentDb() - _PropertyGet = oDatabase._hasDialog(_Name) + _PropertyGet = Application._hasDialog(_Name) Case UCase("Name") _PropertyGet = _Name Case UCase("ObjectType") @@ -602,7 +607,6 @@ Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Varia 'Execute Dim iArgNr As Integer -Dim oDatabase As Object If Len(_A2B_.CalledSub) > 7 And Left(_A2B_.CalledSub, 7) = "Dialog." Then iArgNr = 1 Else iArgNr = 2 If IsNull(UnoDialog) Then Goto Trace_Error_Dialog diff --git a/wizards/source/access2base/DoCmd.xba b/wizards/source/access2base/DoCmd.xba index 91abb0408e84..b3098a1008d4 100644 --- a/wizards/source/access2base/DoCmd.xba +++ b/wizards/source/access2base/DoCmd.xba @@ -43,7 +43,8 @@ Public Function mClose(Optional ByVal pvObjectType As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function - Utils._SetCalledSub("Close") +Const cstThisSub = "Close" + Utils._SetCalledSub(cstThisSub) mClose = False If IsMissing(pvObjectType) Or IsMissing(pvObjectName) Then Call _TraceArguments() If IsMissing(pvSave) Then pvSave = acSavePrompt @@ -56,10 +57,10 @@ Public Function mClose(Optional ByVal pvObjectType As Variant _ Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object Dim i As Integer, bFound As Boolean, lComponent As Long Dim oDatabase As Object - If _TraceStandalone() Then Goto Exit_Function + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable ' Check existence of object and find its exact (case-sensitive) name - Set oDatabase = Application._CurrentDb() Select Case pvObjectType Case acForm sObjects = oDatabase.Document.getFormDocuments.ElementNames() @@ -102,7 +103,7 @@ Dim oDatabase As Object Exit_Function: Set oObject = Nothing Set oController = Nothing - Utils._ResetCalledSub("Close") + Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, "Close", Erl) @@ -113,7 +114,148 @@ Trace_Error: Trace_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Array("Table", "Query", "Form", "Report")(pvObjectType)), pvObjectName)) Goto Exit_Function -End Function ' (m)Close +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' (m)Close V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CopyObject(ByVal Optional pvDestinationDatabase As Variant _ + , ByVal Optional pvNewName As Variant _ + , ByVal Optional pvSourceType As Variant _ + , ByVal Optional pvSourceName As Variant _ + ) As Boolean +' Copies tables and queries into identical (new) objects + If _ErrorHandler() Then On Local Error Goto Error_Function +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(pvNewName) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvNewName, 2, vbString) Then Goto Exit_Function + If IsMissing(pvSourceType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvSourceType, 1, Utils._AddNumeric(), Array(acQuery, acTable) _ + ) Then Goto Exit_Function + 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 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 + + Set oDatabase = Application._CurrentDb() + + With oDatabase + If ._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + Select Case pvSourceType + + Case acQuery + Set oSource = .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 + If oSource.Query.EscapeProcessing Then + Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL) + Else + Set oTarget = .CreateQueryDef(pvNewName, oSource.SQL, dbSQLPassThrough) + End If + ' Save .odb document + .Document.store() + + Case acTable + Set oSource = .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 + ' Copy source table columns + Set oSourceTable = oSource.Table + Set oTarget = .Connection.getTables.createDataDescriptor + oTarget.Description = oSourceTable.Description + oTarget.Name = pvNewName + oTarget.Type = oSourceTable.Type + Set oSourceColumns = oSourceTable.Columns + Set oTargetCol = oTarget.Columns.createDataDescriptor + 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 + oTarget.Columns.appendByDescriptor(oTargetCol) + Next i + ' Copy keys + Set oSourceKeys = oSourceTable.Keys + Set oTargetKey = oTarget.Keys.createDataDescriptor() + For i = 0 To oSourceKeys.getCount() - 1 + ' Append each key to table descriptor + Set oSourceKey = oSourceKeys.getByIndex(i) + oTargetKey.DeleteRule = oSourceKey.DeleteRule + 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 + oTargetKey.Columns.appendByDescriptor(oTargetCol) + Next j + oTarget.Keys.appendByDescriptor(oTargetKey) + Next i + ' Duplicate table whole design + .Connection.getTables.appendByDescriptor(oTarget) + ' Copy data + sSql = "INSERT INTO [" & pvNewName & "] SELECT [" & oSource.Name & "].* FROM [" & oSource.Name & "]" + DoCmd.RunSQL(sSql, dbSQLPassthrough) + + Case Else + End Select + End With + + CopyObject = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Set oSourceCol = Nothing + Set oSourceKey = Nothing + Set oSourceKeys = Nothing + Set oSource = Nothing + Set oSourceTable = Nothing + Set oSourceColumns = Nothing + Set oTargetCol = Nothing + Set oTargetKey = Nothing + Set oTarget = Nothing + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(Iif(pvSourceType = acQuery, _GetLabel("QUERY"), _GetLabel("TABLE")), pvSourceName)) + Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' CopyObject V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function FindNext() As Boolean @@ -129,12 +271,13 @@ Dim i As Integer, lInitialRow As Long, lFindRow As Long Dim bFound As Boolean, b2ndRound As Boolean, bStop As Boolean Dim vFindValue As Variant, oFindrecord As Object - oFindRecord = Application.CurrentDb().FindRecord + Set oFindRecord = _A2B_.FindRecord With oFindRecord If .FindRecord = 0 Then Goto Error_FindRecord .FindRecord = 0 Set ofForm = getObject(.Form) + If ofForm._Type = OBJCONTROL Then Set ofForm = ofForm.Form ' Bug Tombola Set ocGrid = getObject(.GridControl) ' Move cursor to the initial row. Operation based on last FindRecord, not on user interactions done inbetween @@ -232,7 +375,7 @@ Error_Function: Error_FindRecord: TraceError(TRACEERRORS, ERRFINDRECORD, Utils._CalledSub(), 0) Goto Exit_Function -End Function ' FindNext V0.9.0 +End Function ' FindNext V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function FindRecord(Optional ByVal pvFindWhat As Variant _ @@ -330,6 +473,7 @@ Dim oFindRecord As _FindParams If vParentGrid.SubType <> CTLGRIDCONTROL Then Goto Error_Target .GridControl = vParentGrid._Shortcut ofParentForm = getObject(_getUpperShortcut(vParentGrid._Shortcut, vParentGrid._Name)) + If ofParentForm._Type = OBJCONTROL Then Set ofParentForm = ofParentForm.Form ' Bug Tombola If IsNull(ofParentForm.DatabaseForm) Then Goto Error_DatabaseForm .Target = ocTarget._Shortcut Set vDataField = ocTarget.ControlModel.BoundField @@ -444,7 +588,7 @@ Dim oFindRecord As _FindParams .FindRecord = 1 End With - Set Application.CurrentDb().FindRecord = oFindRecord + Set _A2B_.FindRecord = oFindRecord FindRecord = DoCmd.Findnext() Exit_Function: @@ -465,7 +609,46 @@ Error_Target: Error_NoGrid: TraceError(TRACEFATAL, ERRNOGRIDINFORM, Utils._CalledSub(), 0, 1, vParentForm._Name) Goto Exit_Function -End Function ' FindRecord V0.9.1 +End Function ' FindRecord V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GetHiddenAttribute(ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "GetHiddenAttribute" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvObjectType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _ + ) Then Goto Exit_Function + If IsMissing(pvObjectName) Then + Select Case pvObjectType + Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() + Case Else + End Select + pvObjectName = "" + Else + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + End If + +Dim oWindow As Object + Set oWindow = _SelectWindow(pvObjectType, pvObjectName) + If IsNull(oWindow.Frame) Then Goto Error_NotFound + GetHiddenAttribute = Not oWindow.Frame.ContainerWindow.isVisible() + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' GetHiddenAttribute V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function GoToControl(Optional ByVal pvControlName As variant) As Boolean @@ -617,10 +800,10 @@ Error_ActiveForm: TraceError(TRACEERRORS, ERRNOACTIVEFORM, Utils._CalledSub(), 0) Goto Exit_Function Error_Target: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, 2) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(2, pvObjectName)) Goto Exit_Function Error_Offset: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, 4) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(4, pvOffset)) Goto Exit_Function End Function ' GoToRecord @@ -659,8 +842,8 @@ Dim oWindow As Object End Function ' Minimize V0.8.5 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function MoveSize(ByVal Optional pvRight As Variant _ - , ByVal Optional pvDown As Variant _ +Public Function MoveSize(ByVal Optional pvLeft As Variant _ + , ByVal Optional pvTop As Variant _ , ByVal Optional pvWidth As Variant _ , ByVal Optional pvHeight As Variant _ ) As Variant @@ -668,28 +851,35 @@ Public Function MoveSize(ByVal Optional pvRight As Variant _ Utils._SetCalledSub("MoveSize") If _ErrorHandler() Then On Local Error Goto Error_Function MoveSize = False - If IsMissing(pvRight) Then pvRight = -1 - If IsMissing(pvDown) Then pvDown = -1 + If IsMissing(pvLeft) Then pvLeft = -1 + If IsMissing(pvTop) Then pvTop = -1 If IsMissing(pvWidth) Then pvWidth = -1 If IsMissing(pvHeight) Then pvHeight = -1 - If Not Utils._CheckArgument(pvRight, 1, Utils._AddNumeric()) Then Goto Exit_Function - If Not Utils._CheckArgument(pvDown, 2, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvLeft, 1, Utils._AddNumeric()) Then Goto Exit_Function + If Not Utils._CheckArgument(pvTop, 2, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvWidth, 3, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvHeight, 4, Utils._AddNumeric()) Then Goto Exit_Function -Dim iArg As Integer ' Check argument values +Dim iArg As Integer, iWrong As Integer ' Check arguments values iArg = 0 - If pvHeight < -1 Then iArg = 4 : If pvWidth < -1 Then iArg = 3 - If pvDown < -1 Then iArg = 2 : If pvRight < -1 Then iArg = 2 + If pvHeight < -1 Then + iArg = 4 : iWrong = pvHeight + ElseIf pvWidth < -1 Then + iArg = 3 : iWrong = pvWidth + ElseIf pvTop < -1 Then + iArg = 2 : iWrong = pvTop + ElseIf pvLeft < -1 Then + iArg = 1 : iWrong = pvLeft + End If If iArg > 0 Then - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, iArg) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArg, iWrong)) Goto Exit_Function End If - + Dim iPosSize As Integer iPosSize = 0 - If pvRight >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X - If pvDown >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y + If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X + If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT @@ -701,7 +891,7 @@ Dim oWindow As Object .Frame.ContainerWindow.IsMaximized = False .Frame.ContainerWindow.IsMinimized = False End If - .Frame.ContainerWindow.setPosSize(pvRight, pvDown, pvWidth, pvHeight, iPosSize) + .Frame.ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize) MoveSize = True End If End With @@ -712,7 +902,7 @@ Exit_Function: Error_Function: TraceError(TRACEABORT, Err, "MoveSize", Erl) GoTo Exit_Function -End Function ' MoveSize V0.8.5 +End Function ' MoveSize V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenForm(Optional ByVal pvFormName As Variant _ @@ -744,9 +934,10 @@ Public Function OpenForm(Optional ByVal pvFormName As Variant _ ) Then Goto Exit_Function Dim ofForm As Object, sWarning As String -Dim oOpenForm As Object, bOpenMode As Boolean, oController As Object +Dim oDatabase As Object, oOpenForm As Object, bOpenMode As Boolean, oController As Object - If _TraceStandalone() Then Goto Exit_Function + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable Set ofForm = Application.AllForms(pvFormName) If ofForm.IsLoaded Then @@ -761,7 +952,7 @@ Dim oOpenForm As Object, bOpenMode As Boolean, oController As Object Case acNormal, acPreview: bOpenMode = False Case acDesign : bOpenMode = True End Select - Set oController = Application._CurrentDb().Document.CurrentController + Set oController = oDatabase.Document.CurrentController Set oOpenForm = oController.loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, ofForm._Name, bOpenMode) ' Apply the filters (FilterName) AND (WhereCondition) @@ -784,7 +975,7 @@ Dim sFilter As String, oForm As Object, oFormsCollection As Object Goto Trace_Error End If If sFilter <> "" Then - oForm.Filter = Utils._ReplaceSquareBrackets(sFilter) + oForm.Filter = oDatabase._ReplaceSquareBrackets(sFilter) oForm.ApplyFilter = True oForm.reload() ElseIf oForm.Filter <> "" Then ' If a filter has been set previously it must be removed @@ -828,6 +1019,9 @@ Error_Function: TraceError(TRACEABORT, Err, "OpenForm", Erl) Set OpenForm = Nothing GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function Trace_Error: TraceError(TRACEFATAL, ERROPENFORM, Utils._CalledSub(), 0, , pvFormName) Set OpenForm = Nothing @@ -885,7 +1079,6 @@ Public Function OpenSQL(Optional ByVal pvSQL As Variant _ ' Return True if the execution of the SQL statement was successful ' SQL must contain a SELECT query ' pvOption can force pass through mode -' Derived from BaseTools If _ErrorHandler() Then On Local Error Goto Error_Function @@ -901,26 +1094,7 @@ Const cstNull = -1 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function End If -Dim oDatabase As Object, oURL As New com.sun.star.util.URL, oDispatch As Object -Dim vArgs(8) as New com.sun.star.beans.PropertyValue - - Set oDatabase = _CurrentDb - - oURL.Complete = ".component:DB/DataSourceBrowser" - oDispatch = StarDesktop.queryDispatch(oURL, "_Blank", 8) - - vArgs(0).Name = "ActiveConnection" : vArgs(0).Value = CurrentDb.Connection - vArgs(1).Name = "CommandType" : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND - vArgs(2).Name = "Command" : vArgs(2).Value = Utils._ReplaceSquareBrackets(pvSQL) - vArgs(3).Name = "ShowMenu" : vArgs(3).Value = True - vArgs(4).Name = "ShowTreeView" : vArgs(4).Value = False - vArgs(5).Name = "ShowTreeViewButton" : vArgs(5).Value = False - vArgs(6).Name = "Filter" : vArgs(6).Value = "" - vArgs(7).Name = "ApplyFilter" : vArgs(7).Value = False - vArgs(8).Name = "EscapeProcessing" : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough )) - - oDispatch.dispatch(oURL, vArgs) - OpenSQL = True + OpenSQL = Application._CurrentDb.OpenSQL(pvSQL, pvOption) Exit_Function: Utils._ResetCalledSub("OpenSQL") @@ -928,10 +1102,7 @@ Exit_Function: Error_Function: TraceError(TRACEABORT, Err, "OpenSQL", Erl) GoTo Exit_Function -SQL_Error: - TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) - Goto Exit_Function -End Function ' OpenSQL V0.9.5 +End Function ' OpenSQL V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenTable(Optional ByVal pvTableName As Variant _ @@ -1049,7 +1220,7 @@ Dim sOutputFormat As String, sFilter As String, oFilterData As Object, oExport A Else sOutputFile = pvOutputFile End If - sOutputFile = _ConvertToURL(sOutputFile) + sOutputFile = ConvertToURL(sOutputFile) 'Create file On Local Error Goto Error_File @@ -1065,7 +1236,7 @@ Exit_Function: Utils._ResetCalledSub("OutputTo") Exit Function Error_NotFound: - TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Object", pvObjectName)) + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) Goto Exit_Function Error_Action: TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0) @@ -1084,21 +1255,22 @@ Public Function Quit(Optional ByVal pvSave As Variant) As Variant ' Modified from Andrew Pitonyak's Base Macro Programming §5.8.1 If _ErrorHandler() Then On Local Error Goto Error_Function - Utils._SetCalledSub("Quit") +Const cstThisSub = "Quit" + Utils._SetCalledSub(cstThisSub) If IsMissing(pvSave) Then pvSave = acQuitSaveAll If Not Utils._CheckArgument(pvSave, 1, Utils._AddNumeric(), _ Array(acQuitPrompt, acQuitSaveAll, acQuitSaveNone) _ ) Then Goto Exit_Function -Dim vDatabase As Variant, oDoc As Object - vDatabase = CurrentDb - If Not IsNull(vDatabase) Then - Set oDoc = vDatabase.Document +Dim oDatabase As Object, oDoc As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + If Not IsNull(oDatabase) Then + Set oDoc = oDatabase.Document Select Case pvSave Case acQuitPrompt - If MsgBox(_GetLabel("QUIT"), _ - vbYesNo + vbQuestion, _GetLabel("QUITSHORT")) = vbNo Then Exit Function + If MsgBox(_GetLabel("QUIT"), vbYesNo + vbQuestion, _GetLabel("QUITSHORT")) = vbNo Then Exit Function Case acQuitSaveNone oDoc.setModified(False) Case Else @@ -1116,15 +1288,18 @@ Dim vDatabase As Variant, oDoc As Object End If Exit_Function: - Utils._ResetCalledSub("Quit") - Set vDatabase = Nothing + Utils._ResetCalledSub(cstThisSub) + Set oDatabase = Nothing Set oDoc = Nothing Exit Function Error_Function: - TraceError(TRACEABORT, Err, "Quit", Erl) + TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) Set OpenForm = Nothing GoTo Exit_Function -End Function ' Quit +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' Quit V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub RunApp(Optional ByVal pvCommandLine As Variant) @@ -1137,7 +1312,7 @@ Public Sub RunApp(Optional ByVal pvCommandLine As Variant) If IsMissing(pvCommandLine) Then Call _TraceArguments() If Not Utils._CheckArgument(pvCommandLine, 1, vbString) Then Goto Exit_Sub - _ShellExecute(_ConvertToURL(pvCommandLine)) + _ShellExecute(ConvertToURL(pvCommandLine)) Exit_Sub: Utils._ResetCalledSub("RunApp") @@ -1384,15 +1559,7 @@ Const cstNull = -1 If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function End If -Dim oDatabase As Object, oStatement As Object, vResult As Variant - Set oDatabase = _CurrentDb - - Set oStatement = oDatabase.Connection.createStatement() - oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough ) - On Local Error Goto SQL_Error - vResult = oStatement.executeUpdate(Utils._ReplaceSquareBrackets(pvSQL)) - On Local Error Goto Error_Function - RunSQL = True + RunSQL = Application._CurrentDb.RunSQL(pvSQL, pvOption) Exit_Function: Utils._ResetCalledSub("RunSQL") @@ -1400,27 +1567,25 @@ Exit_Function: Error_Function: TraceError(TRACEABORT, Err, "RunSQL", Erl) GoTo Exit_Function -SQL_Error: - TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL) - Goto Exit_Function -End Function ' RunSQL V0.7.5 +End Function ' RunSQL V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function SelectObject( Optional pvObjectType As Variant _ - , Optional pvObjectName As Variant _ - , Optional pvInDatabaseWindow As Variant _ +Public Function SelectObject( ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvInDatabaseWindow As Variant _ ) As Boolean If _ErrorHandler() Then On Local Error Goto Error_Function - Utils._SetCalledSub("SelectObject") +Const cstThisSub = "SelectObject" + Utils._SetCalledSub(cstThisSub) If IsMissing(pvObjectType) Then Call _TraceArguments() If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ - Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow) _ + Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow, acDocument) _ ) Then Goto Exit_Function If IsMissing(pvObjectName) Then Select Case pvObjectType - Case acForm, acQuery, acTable, acReport : Call _TraceArguments() + Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() Case Else End Select pvObjectName = "" @@ -1434,19 +1599,24 @@ Public Function SelectObject( Optional pvObjectType As Variant _ Dim oWindow As Object Set oWindow = _SelectWindow(pvObjectType, pvObjectName) If IsNull(oWindow.Frame) Then Goto Error_NotFound - oWindow.Frame.ContainerWindow.setFocus() - oWindow.Frame.ContainerWindow.setEnable(True) ' Added to try to bypass desynchro issue in Linux + With oWindow.Frame.ContainerWindow + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .setEnable(True) ' Added to try to bypass desynchro issue in Linux + .toFront() ' Added to force window change in Linux + End With Exit_Function: - Utils._ResetCalledSub("SelectObject") + Utils._ResetCalledSub(cstThisSub) Exit Function Error_NotFound: - TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Object", pvObjectName)) + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) Goto Exit_Function Error_Function: - TraceError(TRACEABORT, Err, "SelectObject", Erl) + TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function -End Function ' SelectObject V0.8.5 +End Function ' SelectObject V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function SendObject(ByVal Optional pvObjectType As Variant _ @@ -1537,7 +1707,7 @@ Exit_Function: Utils._ResetCalledSub("SendObject") Exit Function Error_NotFound: - TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Object", pvObjectName)) + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "SendObject", Erl) @@ -1551,12 +1721,65 @@ Error_File: End Function ' SendObject V0.8.5 REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetHiddenAttribute(ByVal Optional pvObjectType As Variant _ + , ByVal Optional pvObjectName As Variant _ + , ByVal Optional pvHidden As Variant _ + ) As Boolean + + If _ErrorHandler() Then On Local Error Goto Error_Function + SetHiddenAttribute = False +Const cstThisSub = "SetHiddenAttribute" + Utils._SetCalledSub(cstThisSub) + + If IsMissing(pvObjectType) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), _ + Array(acDiagram, acForm, acQuery, acTable, acReport, acBasicIDE, acDatabaseWindow), acDocument _ + ) Then Goto Exit_Function + If IsMissing(pvObjectName) Then + Select Case pvObjectType + Case acForm, acQuery, acTable, acReport, acDocument : Call _TraceArguments() + Case Else + End Select + pvObjectName = "" + Else + If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function + End If + If IsMissing(pvHidden) Then + pvHidden = True + Else + If Not Utils._CheckArgument(pvHidden, 3, vbBoolean) Then Goto Exit_Function + End If + +Dim oWindow As Object + Set oWindow = _SelectWindow(pvObjectType, pvObjectName) + If IsNull(oWindow.Frame) Then Goto Error_NotFound + oWindow.Frame.ContainerWindow.setVisible(Not pvHidden) + SetHiddenAttribute = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName)) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' SetHiddenAttribute V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- Public Function ShowAllrecords() As Boolean ' Removes any existing filter that exists on the current table, query or form - Utils._SetCalledSub("ShowAllrecords") +Const cstThisSub = "ShowAllRecords" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function ShowAllRecords = False -Dim oWindow As Object + +Dim oWindow As Object, oDatabase As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + Set oWindow = _SelectWindow() Select Case oWindow.WindowType Case acForm, acQuery, acTable @@ -1566,9 +1789,15 @@ Dim oWindow As Object End Select Exit_Function: - Utils._ResetCalledSub("ShowAllrecords") + Utils._ResetCalledSub(cstThisSub) Exit Function -End Function ' ShowAllrecords V0.7.5 +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' ShowAllrecords V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- @@ -1596,22 +1825,6 @@ Dim bFound As Boolean End Function ' _CheckColumnType V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function _ConvertToURL(psFile As String) As String -' Convert psFile to URL only if necessary - -Dim bURL As Boolean - Select Case True - Case Len(psFile < 7) : bURL = False - Case LCase(Left(psFile, 7)) = "file://" : bURL = True - Case LCase(Left(psFile, 6)) = "ftp://" : bURL = True - Case Else : bURL = False - End Select - - If bURL Then _ConvertToURL = psFile Else _ConvertToURL = ConvertToURL(psFile) - -End Function - -REM ----------------------------------------------------------------------------------------------------------------------- Private Function _getTempDirectoryURL() As String ' Return the tempry directory defined in the OO Options (Paths) Dim sDirectory As String, oSettings As Object, oPathSettings As Object @@ -1668,12 +1881,12 @@ Private Function _OpenObject(ByVal psObjectType As String _ And Utils._CheckArgument(pvView, 2, Utils._AddNumeric(), Array(acViewNormal, acViewPreview, acViewDesign)) _ And Utils._CheckArgument(pvDataMode, 3, Utils._AddNumeric(), Array(acEdit)) _ ) Then Goto Exit_Function - If _TraceStandalone() Then Goto Exit_Function +Dim oDatabase As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable Dim sObjects() As String, sObjectName As String, oController As Object, oObject As Object Dim i As Integer, bFound As Boolean, lComponent As Long -Dim oDatabase As Object - Set oDatabase = Application._CurrentDb() ' Check existence of object and find its exact (case-sensitive) name Select Case psObjectType @@ -1711,6 +1924,9 @@ Error_Function: Trace_Error: TraceError(TRACEFATAL, ERROPENOBJECT, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName)) Goto Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function Trace_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(psObjectType), pvObjectName)) Goto Exit_Function @@ -1722,8 +1938,13 @@ Private Function _PromptFormat() As String Dim oDialog As Object, oDialogLib As Object, iOKCancel As Integer, oControl As Object Set oDialogLib = DialogLibraries - If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base") - Set oDialog = CreateUnoDialog(DialogLibraries.Access2Base.dlgFormat) + If oDialogLib.hasByName("Access2BaseDev") Then + If Not oDialogLib.IsLibraryLoaded("Access2BaseDev") Then oDialogLib.loadLibrary("Access2BaseDev") + Set oDialog = CreateUnoDialog(DialogLibraries.Access2BaseDev.dlgFormat) + Else + If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base") + Set oDialog = CreateUnoDialog(DialogLibraries.Access2Base.dlgFormat) + End If oDialog.Title = _GetLabel("DLGFORMAT_TITLE") Set oControl = oDialog.Model.getByName("lblFormat") @@ -1760,13 +1981,14 @@ Public Function _SelectWindow(Optional ByVal piWindowType As Integer, Optional B ' Return a _Window object type describing the found window Dim oEnum As Object, oDesk As Object, oComp As Object, oFrame As Object, i As Integer -Dim bFound As Boolean, bActive As Boolean, bValid As Boolean, sName As String, iType As Integer -Dim sImplementation As String +Dim bFound As Boolean, bActive As Boolean, bName As Boolean, sName As String, iType As Integer +Dim sImplementation As String, vLocation() As Variant Dim oWindow As _Window If _ErrorHandler() Then On Local Error Goto Error_Function bActive = IsMissing(piWindowType) + If IsMissing(psWindow) Then psWindow = "" Set oWindow.Frame = Nothing If bActive Then oWindow.WindowType = -1 @@ -1783,7 +2005,7 @@ Dim oWindow As _Window Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") Set oEnum = oDesk.Components().createEnumeration Do While oEnum.hasMoreElements - oComp = oEnum.nextElement + Set oComp = oEnum.nextElement If Utils._hasUNOProperty(oComp, "ImplementationName") Then sImplementation = oComp.ImplementationName Else sImplementation = "" Select Case sImplementation Case "com.sun.star.comp.basic.BasicIDE" @@ -1795,27 +2017,28 @@ Dim oWindow As _Window iType = acDatabaseWindow sName = "" Case "SwXTextDocument" - bValid = True + bName = False If HasUnoInterfaces(oComp, "com.sun.star.frame.XModule") Then Select Case oComp.Identifier Case "com.sun.star.sdb.FormDesign" ' Form iType = acForm Case "com.sun.star.sdb.TextReportDesign" ' Report iType = acReport - Case "com.sun.star.text.TextDocument" ' Potential standalone form - If Not IsNull(CurrentDb(oComp.URL)) Then iType = acForm Else bValid = False - Case Else - bValid = False ' Ignore other Writer documents + Case "com.sun.star.text.TextDocument" ' Writer + vLocation = Split(oComp.getLocation(), "/") + sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") + bName = True + iType = acDocument End Select - If bValid Then + If Not bName Then ' Identify Form or Report name For i = 0 To UBound(oComp.Args()) - If oComp.Args(i).Name = "DocumentTitle" Or oComp.Args(i).Name = "Title" Then ' Title for standalone forms + If oComp.Args(i).Name = "DocumentTitle" Then sName = oComp.Args(i).Value Exit For End If Next i - Set oFrame = oComp.CurrentController.Frame End If + Set oFrame = oComp.CurrentController.Frame End If Case "org.openoffice.comp.dbu.ODatasourceBrowser" Set oFrame = oComp.Frame @@ -1853,8 +2076,13 @@ Dim oWindow As _Window Set oFrame = oComp.Frame iType = acDiagram sName = "" - Case Else ' Ignore other Calc, ..., whatever documents - Set oFrame = Nothing + Case Else ' Other Calc, ..., whatever documents + If Utils._hasUNOProperty(oComp, "Location") Then + vLocation = Split(oComp.getLocation(), "/") + sName = Join(Split(vLocation(UBound(vLocation)), "%20"), " ") + iType = acDocument + Set oFrame = oComp.CurrentController.Frame + End If End Select If bActive And Not IsNull(oFrame) Then If oFrame.ContainerWindow.IsActive() Then @@ -1881,7 +2109,7 @@ Exit_Function: Error_Function: TraceError(TRACEABORT, Err, "SelectWindow", Erl) GoTo Exit_Function -End Function ' _SelectWindow V0.9.0 +End Function ' _SelectWindow V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _SendWithAttachment( _ diff --git a/wizards/source/access2base/Event.xba b/wizards/source/access2base/Event.xba index 65d38f735eb3..e1408ab691e2 100644 --- a/wizards/source/access2base/Event.xba +++ b/wizards/source/access2base/Event.xba @@ -238,10 +238,10 @@ Public Sub _Initialize(poEvent As Object) Dim oObject As Object, i As Integer Dim sShortcut As String, sAddShortcut As String, sArray() As String Dim sImplementation As String, oSelection As Object -Dim oDatabase As Object +Dim iCurrentDoc As Integer, oDoc As Object Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm" - If _ErrorHandler() Then On Local Error Goto trace_Error + If _ErrorHandler() Then On Local Error Goto Error_Function Set oObject = poEvent.Source _EventSource = oObject @@ -297,8 +297,9 @@ Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm" End Select ' Evaluate ContextShortcut - oDatabase = Application.CurrentDb() - If IsNull(oDatabase) Then Goto Exit_Function + iCurrentDoc = Application._CurrentDoc() + If iCurrentDoc < 0 Then Goto Exit_Function + Set oDoc = _A2B_.CurrentDoc(iCurrentDoc) sShortcut = "" sImplementation = Utils._ImplementationName(oObject) @@ -327,7 +328,7 @@ Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm" If oObject.Name <> "MainForm" And oObject.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Name) End If If sAddShortcut <> "" Then - If sImplementation = cstDatabaseForm And Not oDatabase._Standalone Then sAddShortcut = sAddShortcut & ".Form" + If sImplementation = cstDatabaseForm And oDoc.DbConnect = DBCONNECTBASE Then sAddShortcut = sAddShortcut & ".Form" sShortcut = sAddShortcut & Iif(Len(sShortcut) > 0, "!" & sShortcut, "") End If End Select @@ -342,8 +343,8 @@ Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm" sImplementation = Utils._ImplementationName(oObject) Loop ' Add Forms! prefix - Select Case oDatabase._Standalone - Case False +' Select Case oDoc.DbConnect +' Case DBCONNECTBASE If Utils._hasUNOProperty(oObject, "Args") Then ' Current object is a SwXTextDocument For i = 0 To UBound(oObject.Args) If oObject.Args(i).Name = "DocumentTitle" Then @@ -353,24 +354,21 @@ Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm" Next i End If sShortcut = "Forms!" & sAddShortcut & "!" & sShortcut - Case True - sShortcut = "Forms!0!" & sShortcut - End Select +' Case DBCONNECTFORM +' sShortcut = "Forms!0!" & sShortcut +' End Select sArray = Split(sShortcut, "!") ' If presence of "Forms!myform!myform.Form", eliminate 2nd element + ' Eliminate anyway blanco subcomponents (e.g; Forms!!myForm) If UBound(sArray) >= 2 Then - If UCase(sArray(1)) & ".FORM" = UCase(sArray(2)) Then - sArray(1) = "" - sArray = Utils._TrimArray(sArray) - End If + If UCase(sArray(1)) & ".FORM" = UCase(sArray(2)) Then sArray(1) = "" + sArray = Utils._TrimArray(sArray) End If ' If first element ends with .Form, remove suffix If UBound(sArray) >= 1 Then - If Len(sArray(1)) > 5 And Right(sArray(1), 5) = ".Form" Then - sArray(1) = left(sArray(1), Len(sArray(1)) - 5) - sShortcut = Join(sArray, "!") - End If + If Len(sArray(1)) > 5 And Right(sArray(1), 5) = ".Form" Then sArray(1) = left(sArray(1), Len(sArray(1)) - 5) + sShortcut = Join(sArray, "!") End If If Len(sShortcut) >= 2 Then If Right(sShortcut, 1) = "!" Then @@ -385,10 +383,6 @@ Exit_Function: Error_Function: TraceError(TRACEWARNING, Err, "Event.Initialize", Erl) GoTo Exit_Function -Trace_Error: - ' Errors are not displayed to avoid display infinite cycling - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, 1) - Goto Exit_Function End Sub ' _Initialize V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- @@ -456,16 +450,16 @@ Dim vEMPTY As Variant _PropertyGet = _Recommendation Case UCase("RowChangeAction") _PropertyGet = _RowChangeAction - Case UCase("SubComponentName") - _PropertyGet = _SubComponentName - Case UCase("SubComponentType") - _PropertyGet = _SubComponentType Case UCase("Source") If _ContextShortcut = "" Then - _PropertyGet = Application.CurrentDb() + _PropertyGet = _EventSource Else _PropertyGet = getObject(_ContextShortcut) End If + Case UCase("SubComponentName") + _PropertyGet = _SubComponentName + Case UCase("SubComponentType") + _PropertyGet = _SubComponentType Case UCase("XPos") If IsNull(_XPos) Then Goto Trace_Error _PropertyGet = _XPos @@ -488,5 +482,5 @@ Error_Function: TraceError(TRACEABORT, Err, "Event._PropertyGet", Erl) _PropertyGet = vEMPTY GoTo Exit_Function -End Function ' _PropertyGet +End Function ' _PropertyGet V1.1.0 </script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Field.xba b/wizards/source/access2base/Field.xba index 39fbfeca3306..4819e832e631 100644 --- a/wizards/source/access2base/Field.xba +++ b/wizards/source/access2base/Field.xba @@ -18,6 +18,7 @@ Private _Type As String ' Must be FIELD Private _Name As String Private _ParentName As String Private _ParentType As String +Private _ParentDatabase As Object Private Column As Object ' com.sun.star.sdb.OTableColumnWrapper ' or org.openoffice.comp.dbaccess.OQueryColumn ' or com.sun.star.sdb.ODataColumn @@ -54,15 +55,23 @@ Property Get DbType() As Long ' MSAccess type End Property ' DbType (get) REM ----------------------------------------------------------------------------------------------------------------------- -Property Get DefaultValue() As String +Property Get DefaultValue() As Variant DefaultValue = _PropertyGet("DefaultValue") End Property ' DefaultValue (get) +Property Let DefaultValue(ByVal pvDefaultValue As Variant) + Call _PropertySet("DefaultValue", pvDefaultValue) +End Property ' DefaultValue (set) + REM ----------------------------------------------------------------------------------------------------------------------- -Property Get Description() As String +Property Get Description() As Variant Description = _PropertyGet("Description") End Property ' Description (get) +Property Let Description(ByVal pvDescription As Variant) + Call _PropertySet("Description", pvDescription) +End Property ' Description (set) + REM ----------------------------------------------------------------------------------------------------------------------- Property Get FieldSize() As Long FieldSize = _PropertyGet("FieldSize") @@ -153,6 +162,7 @@ Const cstThisSub = "Field.Properties" vProperty = PropertiesGet._Properties(sObject, sName, vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If + Set vProperty._ParentDatabase = _ParentDatabase Exit_Function: Set Properties = vProperty @@ -304,7 +314,7 @@ Const cstMaxTextLength = 65535 Case UCase("DefaultValue") If Utils._hasUNOProperty(Column, "DefaultValue") Then ' Default value in database set via SQL statement _PropertyGet = Column.DefaultValue - ElseIf Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition + ElseIf Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition If IsEmpty(Column.ControlDefault) Then _PropertyGet = "" Else _PropertyGet = Column.ControlDefault Else _PropertyGet = "" @@ -388,9 +398,9 @@ Const cstMaxTextLength = 65535 If Utils._hasUNOProperty(Column, "Scale") Then If Column.Scale > 0 Then vValue = Column.getDouble() - Else ' CDec checks local decimal point, getString does not ! + Else ' CLng checks local decimal point, getString does not ! sValue = Join(Split(Column.getString(), "."), Utils._DecimalPoint()) - vValue = CDec(sValue) + vValue = CLng(sValue) ' CDec disappeared from LO ?!? End If Else vValue = CDec(Column.getString()) @@ -444,7 +454,7 @@ Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Error: - TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) + TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) _PropertyGet = vEMPTY Goto Exit_Function Trace_Length: @@ -455,7 +465,7 @@ Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) _PropertyGet = vEMPTY GoTo Exit_Function -End Function ' _PropertyGet +End Function ' _PropertyGet V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean @@ -478,11 +488,21 @@ Dim oParent As Object If Not hasProperty(psProperty) Then Goto Trace_Error Select Case UCase(psProperty) + Case UCase("DefaultValue") + If _ParentType <> OBJTABLEDEF Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + If Utils._hasUNOProperty(Column, "ControlDefault") Then ' Default value set in Base via table edition + Column.ControlDefault = pvValue + End If + Case UCase("Description") + If _ParentType <> OBJTABLEDEF Then Goto Trace_Error + If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value + Column.HelpText = pvValue Case UCase("Value") 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 Application._CurrentDb().Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update + If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update With com.sun.star.sdbc.DataType If IsNull(pvValue) Then If Column.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then Column.updateNull() Else Goto Trace_Null @@ -610,12 +630,12 @@ Public Function _ReadAll(ByVal psFile As String, ByVal psMethod As String) As Bo 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 Application._CurrentDb().Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update + If _ParentDatabase.Recordsets(_ParentName)._EditMode = dbEditNone Then Goto Trace_Error_Update Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object Dim lFileLength As Long, sBuffer As String, sMemo As String, iFile As Integer Const cstMaxLength = 64000 - sFile = _ConvertToURL(psFile) + sFile = ConvertToURL(psFile) oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") If Not oSimpleFileAccess.exists(sFile) Then Goto Trace_File @@ -685,7 +705,7 @@ Public Function _WriteAll(ByVal psFile As String, ByVal psMethod As String) As B _WriteAll = False Dim sFile As String, oSimpleFileAccess As Object, sMethod As String, oStream As Object - sFile = _ConvertToURL(psFile) + sFile = ConvertToURL(psFile) oSimpleFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") With com.sun.star.sdbc.DataType @@ -736,6 +756,14 @@ REM --- CLASS PROPERTY SETs --- REM --- Workaround to bug https://www.libreoffice.org/bugzilla/show_bug.cgi?id=60752 (LibreOffice 4.0) --- REM ----------------------------------------------------------------------------------------------------------------------- +Property Set DefaultValue(ByVal pvDefaultValue As Variant) + Call _PropertySet("DefaultValue", pvDefaultValue) +End Property ' DefaultValue (set) + +Property Set Description(ByVal pvDescription As Variant) + Call _PropertySet("Description", pvDescription) +End Property ' Description (set) + Property Set Value(ByVal pvValue As Variant) Call _PropertySet("Value", pvValue) End Property ' Value (set) diff --git a/wizards/source/access2base/Form.xba b/wizards/source/access2base/Form.xba index da4673b0e4b3..5768674b6d4c 100644 --- a/wizards/source/access2base/Form.xba +++ b/wizards/source/access2base/Form.xba @@ -15,8 +15,11 @@ REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- Private _Type As String ' Must be FORM +Private _This As Object Private _Shortcut As String Private _Name As String +Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure +Private _DbEntry As Integer Private _IsLoaded As Boolean Private _OpenArgs As Variant Public Component As Object ' com.sun.star.text.TextDocument @@ -28,8 +31,11 @@ REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJFORM + Set _This = Nothing _Shortcut = "" _Name = "" + _DocEntry = -1 + _DbEntry = -1 _IsLoaded = False _OpenArgs = "" Set Component = Nothing @@ -135,16 +141,16 @@ Function IsLoaded() As Boolean End If IsLoaded = False -Dim oDatabase As Object, oEnum As Object, oDesk As Object, oComp As Object, bFound As Boolean +Dim oDoc As Object, oDatabase As Object, oEnum As Object, oDesk As Object, oComp As Object, bFound As Boolean Dim i As Integer - Set oDatabase = Application._CurrentDb() - Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") - Set oEnum = oDesk.Components().createEnumeration - bFound = False - While oEnum.hasMoreElements And Not bFound ' Search in all open components if one corresponds with current form - oComp = oEnum.nextElement - Select Case oDatabase._Standalone - Case False + Set oDoc = _A2B_.CurrentDoc(Application._CurrentDoc()) + Select Case oDoc.DbConnect + Case DBCONNECTBASE + Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") + Set oEnum = oDesk.Components().createEnumeration + bFound = False + Do While oEnum.hasMoreElements And Not bFound ' Search in all open components if one corresponds with current form + oComp = oEnum.nextElement If HasUnoInterfaces(oComp, "com.sun.star.frame.XModule") Then If oComp.Identifier = "com.sun.star.sdb.FormDesign" Then For i = 0 To UBound(oComp.Args()) @@ -159,17 +165,11 @@ Dim i As Integer Next i End If End If - Case True - If Utils._hasUNOProperty(oComp, "ImplementationName") Then - If oComp.ImplementationName = "SwXTextDocument" Then - If oComp.Title = oDatabase.Title Then - _IsLoaded = True - Set Component = oDatabase.Document ' Form - End If - End If - End If - End Select - Wend + Loop + Case DBCONNECTFORM + Set Component = oDoc.Document ' Form + _IsLoaded = True ' Interactive form always loaded by design + End Select Set oComp = Nothing IsLoaded = _IsLoaded @@ -179,7 +179,7 @@ Exit_Function: Error_Function: TraceError(TRACEABORT, Err, "Form.getIsLoaded", Erl) GoTo Exit_Function -End Function +End Function ' IsLoaded V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Property Get Name() As String @@ -204,19 +204,20 @@ REM ---------------------------------------------------------------------------- Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant ' Return either an error or an object of type OPTIONGROUP based on its name - Utils._SetCalledSub("Form.OptionGroup") +Const cstThisSub = "Form.OptionGroup" + Utils._SetCalledSub(cstThisSub) If IsMissing(pvGroupName) Then Call _TraceArguments() If _ErrorHandler() Then On Local Error Goto Error_Function - Set OptionGroup = _OptionGroup(pvGroupName, CTLPARENTISFORM, DatabaseForm, Component) + Set OptionGroup = _OptionGroup(pvGroupName, CTLPARENTISFORM, _This) Exit_Function: - Utils._ResetCalledSub("Form.OptionGroup") + Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: - TraceError(TRACEABORT, Err, "Form.OptionGroup", Erl) + TraceError(TRACEABORT, Err, Form.OptionGroup, Erl) GoTo Exit_Function -End Function ' OptionGroup +End Function ' OptionGroup V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Properties(ByVal Optional pvIndex As Variant) As Variant @@ -281,16 +282,20 @@ Public Function mClose() As Variant If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Form.Close") mClose = False - If _TraceStandalone() Then Goto Exit_Function +Dim oDatabase As Object, oController As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable -Dim oController As Object - Set oController = Application.CurrentDb().Document.getFormDocuments.getByName(_Name) + Set oController = oDatabase.Document.getFormDocuments.getByName(_Name) oController.close() mClose = True Exit_Function: Utils._ResetCalledSub("Form.Close") Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "Form.Close", Erl) GoTo Exit_Function @@ -356,15 +361,13 @@ Dim j As Integer End If ocControl._Initialize() + ocControl._DocEntry = _DocEntry + ocControl._DbEntry = _DbEntry Set Controls = ocControl Exit_Function: Utils._ResetCalledSub("Form.Controls") Exit Function -Trace_Error: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , iArg) - Set Controls = Nothing - Goto Exit_Function Trace_Error_NotOpen: TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, , _Name) Set Controls = Nothing @@ -384,6 +387,20 @@ Error_Function: End Function ' Controls REM ----------------------------------------------------------------------------------------------------------------------- +Public Function CurrentDb() As Object +' Returns Database object related to current form + +Const cstThisSub = "Form.CurrentDb" + Utils._SetCalledSub(cstThisSub) + + Set CurrentDb = Application._CurrentDb(_DocEntry, _DbEntry) + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +End Function ' CurrentDb V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant ' Return property value of psProperty property name @@ -428,12 +445,19 @@ Dim iArgNr As Integer If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function -Dim iArg As Integer ' Check arguments values +Dim iArg As Integer, iWrong As Integer ' Check arguments values iArg = 0 - If pvHeight < -1 Then iArg = 4 : If pvWidth < -1 Then iArg = 3 - If pvTop < -1 Then iArg = 2 : If pvLeft < -1 Then iArg = 1 + If pvHeight < -1 Then + iArg = 4 : iWrong = pvHeight + ElseIf pvWidth < -1 Then + iArg = 3 : iWrong = pvWidth + ElseIf pvTop < -1 Then + iArg = 2 : iWrong = pvTop + ElseIf pvLeft < -1 Then + iArg = 1 : iWrong = pvLeft + End If If iArg > 0 Then - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, iArgNr + iArg) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong)) Goto Exit_Function End If @@ -504,20 +528,27 @@ End Function ' Requery REM ----------------------------------------------------------------------------------------------------------------------- Public Function setFocus() As Boolean ' Execute setFocus method - Utils._SetCalledSub("Form.setFocus") +Const cstThisSub = "Form.setFocus" + Utils._SetCalledSub(cstThisSub) If _ErrorHandler() Then On Local Error Goto Error_Function setFocus = False - ContainerWindow.toFront() + With ContainerWindow + If .isVisible() = False Then .setVisible(True) + .IsMinimized = False + .setFocus() + .setEnable(True) ' Added to try to bypass desynchro issue in Linux + .toFront() ' Added to force window change in Linux + End With setFocus = True Exit_Function: - Utils._ResetCalledSub("Form.setFocus") + Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: - TraceError(TRACEABORT, Err, "Form.setFocus", Erl) + TraceError(TRACEABORT, Err, cstThisSub, Erl) Goto Exit_Function -End Function ' setFocus +End Function ' setFocus V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean @@ -533,14 +564,14 @@ REM ---------------------------------------------------------------------------- Public Sub _Initialize(psName As String) ' Set pointers to UNO objects -Dim oDatabase As Object, oFormsCollection As Object +Dim oDoc As Object, oFormsCollection As Object If _ErrorHandler() Then On Local Error Goto Trace_Error _Name = psName _Shortcut = "Forms!" & Utils._Surround(psName) - Set oDatabase = Application._CurrentDb() If IsLoaded Then - Select Case oDatabase._Standalone - Case False + Set oDoc = _A2B_.CurrentDoc(Application._CurrentDoc()) + Select Case oDoc.DbConnect + Case DBCONNECTBASE If Not IsNull(Component.CurrentController) Then ' A form opened then closed afterwards keeps a Component attribute Set ContainerWindow = Component.CurrentController.Frame.ContainerWindow Set oFormsCollection = Component.getDrawPage.Forms @@ -554,9 +585,9 @@ Dim oDatabase As Object, oFormsCollection As Object Goto Trace_Internal_Error End If End If - Case True - Set ContainerWindow = oDatabase.Document.CurrentController.Frame.ContainerWindow - Set DatabaseForm = oDatabase.Form + Case DBCONNECTFORM + Set ContainerWindow = oDoc.Document.CurrentController.Frame.ContainerWindow + Set DatabaseForm = Application._CurrentDb(_DocEntry, _DbEntry).Form End Select Else Set Component = Nothing @@ -572,7 +603,7 @@ Trace_Error: Trace_Internal_Error: TraceError(TRACEABORT, ERRFORMNOTIDENTIFIED, Utils._CalledSub(), 0, , _Name) Goto Exit_Sub -End Sub ' _Initialize +End Sub ' _Initialize V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant @@ -620,10 +651,10 @@ Dim oObject As Object If IsNull(vBookmark) Then Goto Trace_Error _PropertyGet = vBookmark Case UCase("Caption") - Set odatabase = Application._CurrentDb() - Select Case oDatabase._Standalone - Case True : _PropertyGet = oDatabase.Document.CurrentController.Frame.Title - Case False : _PropertyGet = Component.CurrentController.Frame.Title + Set odatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Select Case oDatabase._DbConnect + Case DBCONNECTFORM : _PropertyGet = oDatabase.Document.CurrentController.Frame.Title + Case DBCONNECTBASE : _PropertyGet = Component.CurrentController.Frame.Title End Select Case UCase("CurrentRecord") _PropertyGet = DatabaseForm.Row @@ -645,21 +676,24 @@ Dim oObject As Object If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ?? Set oObject = New Recordset With DatabaseForm - oObject._CommandType = DatabaseForm.CommandType - oObject._Command = DatabaseForm.Command + oObject._CommandType = .CommandType + oObject._Command = .Command oObject._ParentName = _Name oObject._ParentType = _Type + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Set oObject._ParentDatabase = oDatabase + Set oObject._ParentDatabase.Connection = .ActiveConnection oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY ) oObject._PassThrough = ( .EscapeProcessing = False ) oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY ) Call oObject._Initialize() End With - Set oDatabase = Application._CurrentDb() With oDatabase .RecordsetMax = .RecordsetMax + 1 oObject._Name = Format(.RecordsetMax, "0000000") .RecordsetsColl.Add(oObject, UCase(oObject._Name)) End With + If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty Set _PropertyGet = oObject Case UCase("RecordSource") _PropertyGet = DatabaseForm.ActiveCommand @@ -720,10 +754,10 @@ Dim oDatabase As Object DatabaseForm.MoveToBookmark(pvValue) Case UCase("Caption") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value - Set oDatabase = Application._CurrentDb() - Select Case oDatabase._Standalone - Case True : oDatabase.Document.CurrentController.Frame.Title = pvValue - Case False : Component.CurrentController.Frame.Title = pvValue + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Select Case oDatabase._DbConnect + Case DBCONNECTFORM : oDatabase.Document.CurrentController.Frame.Title = pvValue + Case DBCONNECTBASE : Component.CurrentController.Frame.Title = pvValue End Select Case UCase("CurrentRecord") If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value @@ -731,7 +765,7 @@ Dim oDatabase As Object DatabaseForm.absolute(pvValue) Case UCase("Filter") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value - DatabaseForm.Filter = Utils._ReplaceSquareBrackets(pvValue) + DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) Case UCase("FilterOn") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value DatabaseForm.ApplyFilter = pvValue @@ -745,7 +779,7 @@ Dim oDatabase As Object ContainerWindow.setPosSize(0, 0, 0, pvValue, com.sun.star.awt.PosSize.HEIGHT) Case UCase("RecordSource") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value - DatabaseForm.Command = Utils._ReplaceSquareBrackets(pvValue) + DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND DatabaseForm.Filter = "" DatabaseForm.reload() diff --git a/wizards/source/access2base/L10N.xba b/wizards/source/access2base/L10N.xba index b8abab0075ee..ff1ce5bcc29e 100644 --- a/wizards/source/access2base/L10N.xba +++ b/wizards/source/access2base/L10N.xba @@ -25,12 +25,10 @@ Dim sLocal As String Select Case psLocale Case "EN", "DEFAULT" Select Case UCase(psShortlabel) - Case "ERR" & ERRNOTDATABASE : sLocal = "The open document is not an OpenOffice/LibreOffice Database Document" - Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Database connection not established" + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Connection to the database is not active" Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Arguments are missing or are not initialized" Case "ERR" & ERRWRONGARGUMENT : sLocal = "Argument nr. %0 [Value = '%1'] is invalid" - Case "ERR" & ERRMAINFORM : sLocal = "Document '%0' does not contain exactly 1 main form (either none or > 1)" - Case "ERR" & ERRSTANDALONE : sLocal = "Property or method must not be called from a standalone form" + Case "ERR" & ERRMAINFORM : sLocal = "Document '%0' does not contain any form" Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Form '%0' not identified in database Forms set" Case "ERR" & ERRFORMNOTFOUND : sLocal = "Form '%0' not found" Case "ERR" & ERRFORMNOTOPEN : sLocal = "Form '%0' is currently not open" @@ -51,7 +49,6 @@ Dim sLocal As String Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' not found" Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1' could not be opened" Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1' could not be closed" - Case "ERR" & ERRMETHOD : sLocal = "Method not applicable in this context" Case "ERR" & ERRACTION : sLocal = "Action not applicable in this context" Case "ERR" & ERRSENDMAIL : sLocal = "Mail service could not be activated" Case "ERR" & ERRFORMYETOPEN : sLocal = "Form %0 is already open" @@ -70,17 +67,23 @@ Dim sLocal As String 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" & ERRNOTACTIONQUERY : sLocal = "Query '%0' is not an action query" - Case "ERR" & ERRNOTUPDATABLE : sLocal = "Recordset or field is not updatable" + Case "ERR" & ERRNOTUPDATABLE : sLocal = "Database, recordset or field is read only" Case "ERR" & ERRUPDATESEQUENCE : sLocal = "Recordset update sequence error" Case "ERR" & ERRNOTNULLABLE : sLocal = "Field '%0' must not contain a NULL value" - Case "ERR" & ERRROWDELETED : sLocal = "Current row has been deleted" + Case "ERR" & ERRROWDELETED : sLocal = "Current row has been deleted by another process or user" Case "ERR" & ERRRECORDSETCLONE : sLocal = "Cloning a cloned Recordset is forbidden" Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Pre-existing query '%0' has been deleted" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "Pre-existing table '%0' has been deleted" + Case "ERR" & ERRTABLECREATION : sLocal = "Table '%0' could not be created" + Case "ERR" & ERRFIELDCREATION : sLocal = "Field '%0' could not be created" '---------------------------------------------------------------------------------------------------------------------- + Case "OBJECT" : sLocal = "Object" Case "TABLE" : sLocal = "Table" Case "QUERY" : slocal = "Query" Case "FORM" : sLocal = "Form" Case "REPORT" : sLocal = "Report" + Case "RECORDSET" : sLocal = "Recordset" + Case "FIELD" : sLocal = "Field" '---------------------------------------------------------------------------------------------------------------------- Case "ERR#" : sLocal = "Error #" Case "ERROCCUR" : sLocal = "occurred" @@ -126,12 +129,10 @@ Dim sLocal As String End Select Case "FR" Select Case UCase(psShortlabel) - Case "ERR" & ERRNOTDATABASE : sLocal = "Le document actuellement ouvert n'est pas un document OpenOffice/LibreOffice de type Database" - Case "ERR" & ERRDBNOTCONNECTED : sLocal = "La connexion à la banque de données n'est pas établie" + Case "ERR" & ERRDBNOTCONNECTED : sLocal = "Pas de connexion active à la banque de données" Case "ERR" & ERRMISSINGARGUMENTS : sLocal = "Des arguments sont manquants ou non initialisés" Case "ERR" & ERRWRONGARGUMENT : sLocal = "L'argument n° %0 [Valeur = '%1'] n'est pas valable" - Case "ERR" & ERRMAINFORM : sLocal = "Le document '%0' ne contient pas exactement un formulaire principal (soit il n'en a aucun soit > 1)" - Case "ERR" & ERRSTANDALONE : sLocal = "La propriété ou la méthode ne peut pas être invoquée depuis un formulaire (Writer) autonome" + Case "ERR" & ERRMAINFORM : sLocal = "Le document '%0' ne contient aucun formulaire" Case "ERR" & ERRFORMNOTIDENTIFIED : sLocal = "Le formulaire '%0' n'a pas pu être identifié parmi l'ensemble des formulaires de la Database" Case "ERR" & ERRFORMNOTFOUND : sLocal = "Formulaire '%0' non trouvé" Case "ERR" & ERRFORMNOTOPEN : sLocal = "Le formulaire '%0' n'est actuellement pas ouvert" @@ -152,7 +153,6 @@ Dim sLocal As String Case "ERR" & ERROBJECTNOTFOUND : sLocal = "%0 '%1' non trouvé(e)" Case "ERR" & ERROPENOBJECT : sLocal = "%0 '%1': ouverture en échec" Case "ERR" & ERRCLOSEOBJECT : sLocal = "%0 '%1': fermeture en échec" - Case "ERR" & ERRMETHOD : sLocal = "Méthode non applicable dans ce contexte" Case "ERR" & ERRACTION : sLocal = "Action non applicable dans ce contexte" Case "ERR" & ERRSENDMAIL : sLocal = "Le service de messagerie n'a pas pu être activé" Case "ERR" & ERRFORMYETOPEN : sLocal = "Le formulaire %0 est déjà ouvert" @@ -171,17 +171,23 @@ Dim sLocal As String 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" & ERRNOTACTIONQUERY : sLocal = "La requête '%0' n'est pas une requête d'action" - Case "ERR" & ERRNOTUPDATABLE : sLocal = "Ce recordset ou ce champ ne peut pas être mis à jour" + 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" Case "ERR" & ERRNOTNULLABLE : sLocal = "Le champ '%0' ne peut pas recevoir une valeur NULLe" - Case "ERR" & ERRROWDELETED : sLocal = "L'enregistrement courant a été effacé" + Case "ERR" & ERRROWDELETED : sLocal = "L'enregistrement courant a été effacé par un autre processus ou un autre utilisateur" Case "ERR" & ERRRECORDSETCLONE : sLocal = "Le clonage d'un Recordset cloné est interdit" - Case "ERR" & ERRQUERYDEFDELETED : sLocal = "Le query existant '%0' a été supprimé" + Case "ERR" & ERRQUERYDEFDELETED : sLocal = "La requête existante '%0' a été supprimée" + Case "ERR" & ERRTABLEDEFDELETED : sLocal = "La table existante '%0' a été supprimée" + Case "ERR" & ERRTABLECREATION : sLocal = "La table '%0' n'a pas pu être créée" + Case "ERR" & ERRFIELDCREATION : sLocal = "Le champ '%0' n'a pas pu être créé" '---------------------------------------------------------------------------------------------------------------------- + Case "OBJECT" : sLocal = "Objet" Case "TABLE" : sLocal = "Table" Case "QUERY" : slocal = "Requête" Case "FORM" : sLocal = "Formulaire" Case "REPORT" : sLocal = "Rapport" + Case "RECORDSET" : sLocal = "Recordset" + Case "FIELD" : sLocal = "Champ" '---------------------------------------------------------------------------------------------------------------------- Case "ERR#" : sLocal = "L'erreur #" Case "ERROCCUR" : sLocal = "s'est produite" diff --git a/wizards/source/access2base/Methods.xba b/wizards/source/access2base/Methods.xba index 609fda01bb9f..8d7a11aaa0a0 100644 --- a/wizards/source/access2base/Methods.xba +++ b/wizards/source/access2base/Methods.xba @@ -174,33 +174,32 @@ Error_Function: End Function ' Requery V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function setFocus(Optional pvObject As Variant) As Boolean -' Execute setFocus method +Public Function SetFocus(Optional pvObject As Variant) As Boolean +' Execute SetFocus method Utils._SetCalledSub("setFocus") If IsMissing(pvObject) Then Call _TraceArguments() If _ErrorHandler() Then On Local Error Goto Error_Function If Not Utils._CheckArgument(pvObject, 1, Array(OBJFORM, OBJCONTROL)) Then Goto Exit_Function - setFocus = pvObject.setFocus() + SetFocus = pvObject.setFocus() Exit_Function: - Utils._ResetCalledSub("setFocus") + Utils._ResetCalledSub("SetFocus") Exit Function Error_Function: - TraceError(TRACEABORT, Err, "setFocus", Erl) + TraceError(TRACEABORT, Err, "SetFocus", Erl) Goto Exit_Function Error_Grid: TraceError(TRACEFATAL, ERRFOCUSINGRID, Utils._CalledSub(), 0, 1, Array(pvObject._Name, ocGrid._Name)) Goto Exit_Function -End Function ' setFocus V0.9.0 +End Function ' SetFocus V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- Public Function _OptionGroup(ByVal pvGroupName As Variant _ , ByVal psParentType As String _ - , Optional pvDatabaseForm As Object _ - , Optional pvComponent As Object _ + , pvForm As Object _ ) As Variant ' Return either an error or an object of type OPTIONGROUP based on its name @@ -215,59 +214,63 @@ Dim vOptionButtons() As Variant, sGroupName As String Dim lXY() As Long, iIndex() As Integer ' Two indexes X-Y coordinates Dim oView As Object - bFound = False - For i = 0 To pvDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ? - pvDatabaseForm.getGroup(i, vOptionButtons, sGroupName) - If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then - bFound = True - Exit For - End If - Next i - - If bFound Then - ogGroup = New Optiongroup - ogGroup._Name = sGroupName - ogGroup._ButtonsGroup = vOptionButtons - ogGroup._Count = UBound(vOptionButtons) + 1 - ogGroup._ParentType = psParentType - Set ogGroup._ParentComponent = pvComponent - - ReDim lXY(1, ogGroup._Count - 1) - ReDim iIndex(ogGroup._Count - 1) - For i = 0 To ogGroup._Count - 1 ' Find the position of each radiobutton - Set oView = pvComponent.CurrentController.getControl(ogGroup._ButtonsGroup(i)) - lXY(0, i) = oView.PosSize.X - lXY(1, i) = oView.PosSize.Y - Next i Const cstPixels = 10 ' Tolerance on coordinates when drawed approximately - For i = 0 To ogGroup._Count - 1 ' Sort them on XY coordinates - If i = 0 Then - iIndex(0) = 0 - Else - iIndex(i) = i - For j = i - 1 To 0 Step -1 - If lXY(1, i) - lXY(1, j) < - cstPixels Or ( Abs(lXY(1, i) - lXY(1, j)) <= cstPixels And lXY(0, i) - lXY(0, j) < - cstPixels ) Then - iIndex(i) = iIndex(j) - iIndex(j) = iIndex(j) + 1 - End If - Next j + With pvForm + bFound = False + For i = 0 To .DatabaseForm.GroupCount - 1 ' Does a group with the right name exist ? + .DatabaseForm.getGroup(i, vOptionButtons, sGroupName) + If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then + bFound = True + Exit For End If Next i - ogGroup._ButtonsIndex = iIndex() - Set _OptionGroup = ogGroup + If bFound Then + ogGroup = New Optiongroup + ogGroup._Name = sGroupName + ogGroup._ButtonsGroup = vOptionButtons + ogGroup._Count = UBound(vOptionButtons) + 1 + ogGroup._ParentType = psParentType + Set ogGroup._ParentComponent = .Component + ogGroup._DocEntry = ._DocEntry + ogGroup._DbEntry = ._DbEntry + + ReDim lXY(1, ogGroup._Count - 1) + ReDim iIndex(ogGroup._Count - 1) + For i = 0 To ogGroup._Count - 1 ' Find the position of each radiobutton + Set oView = .Component.CurrentController.getControl(ogGroup._ButtonsGroup(i)) + lXY(0, i) = oView.PosSize.X + lXY(1, i) = oView.PosSize.Y + Next i + For i = 0 To ogGroup._Count - 1 ' Sort them on XY coordinates + If i = 0 Then + iIndex(0) = 0 + Else + iIndex(i) = i + For j = i - 1 To 0 Step -1 + If lXY(1, i) - lXY(1, j) < - cstPixels Or ( Abs(lXY(1, i) - lXY(1, j)) <= cstPixels And lXY(0, i) - lXY(0, j) < - cstPixels ) Then + iIndex(i) = iIndex(j) + iIndex(j) = iIndex(j) + 1 + End If + Next j + End If + Next i + ogGroup._ButtonsIndex = iIndex() + + Set _OptionGroup = ogGroup + + Else + + Set _OptionGroup = Nothing + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName)) - Else - - Set _OptionGroup = Nothing - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvGroupName)) - - End If + End If + End With Exit_Function: Exit Function Error_Function: TraceError(TRACEABORT, Err,"_OptionGroup", Erl) GoTo Exit_Function -End Function ' _OptionGroup V0.9.0 +End Function ' _OptionGroup V1.1.0 </script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/OptionGroup.xba b/wizards/source/access2base/OptionGroup.xba index 2276dfc70d83..ab0993d2ec17 100644 --- a/wizards/source/access2base/OptionGroup.xba +++ b/wizards/source/access2base/OptionGroup.xba @@ -18,6 +18,8 @@ Private _Type As String ' Must be FORM Private _Name As String Private _ParentType As String Private _ParentComponent As Object +Private _DocEntry As Integer +Private _DbEntry As Integer Private _ButtonsGroup() As Variant Private _ButtonsIndex() As Variant Private _Count As Long @@ -30,6 +32,8 @@ Private Sub Class_Initialize() _Name = "" _ParentType = "" _ParentComponent = Nothing + _DocEntry = -1 + _DbEntry = -1 _ButtonsGroup = Array() _ButtonsIndex = Array() _Count = 0 @@ -141,15 +145,13 @@ Dim ocControl As Variant, iArgNr As Integer, i As Integer End Select ocControl._Initialize() + ocControl._DocEntry = _DocEntry + ocControl._DbEntry = _DbEntry Set Controls = ocControl Exit_Function: Utils._ResetCalledSub("OptionGroup.Controls") Exit Function -Trace_Error: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , 1) - Set Controls = Nothing - Goto Exit_Function Trace_Error_Index: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) Set Controls = Nothing diff --git a/wizards/source/access2base/PropertiesGet.xba b/wizards/source/access2base/PropertiesGet.xba index eec79ba8c560..460deda74e1c 100644 --- a/wizards/source/access2base/PropertiesGet.xba +++ b/wizards/source/access2base/PropertiesGet.xba @@ -400,14 +400,14 @@ Const cstDOT = "." Dim iCurrentIndex As Integer, vCurrentObject As Variant, sCurrentProperty As String Dim sComponents() As String, sSubComponents() As String, sDialog As String -Dim oDatabase As Object +Dim oDoc As Object Set vCurrentObject = Nothing sComponents = Split(Trim(pvShortcut), cstEXCLAMATION) If UBound(sComponents) = 0 Then Goto Trace_Error If Not Utils._InList(UCase(sComponents(0)), Array("FORMS", "DIALOGS")) Then Goto Trace_Error If sComponents(1) = "0" Or Left(sComponents(1), 2) = "0." Then - oDatabase = Application._CurrentDb() - If oDatabase._Standalone Then sComponents(1) = oDatabase.FormName Else Goto Trace_Error + Set oDoc = _A2B_.CurrentDoc(Application._CurrentDoc()) + If oDoc.DbConnect = DBCONNECTFORM Then sComponents(1) = oDoc.DbContainers(0).FormName Else Goto Trace_Error End If sSubComponents = Split(sComponents(UBound(sComponents)), cstDOT) @@ -438,7 +438,7 @@ Dim oDatabase As Object sDialog = UCase(sComponents(iCurrentIndex)) vCurrentObject = Application.AllDialogs(sDialog) If Not vCurrentObject.IsLoaded Then Goto Trace_Error - Set vCurrentObject.UnoDialog = _CurrentDb.Dialogs.Item(sDialog) + Set vCurrentObject.UnoDialog = _A2B_.Dialogs.Item(sDialog) 'Case Else End Select Case OBJFORM, OBJSUBFORM, OBJCONTROL, OBJDIALOG @@ -453,7 +453,7 @@ Exit_Function: Utils._ResetCalledSub("getObject") Exit Function Trace_Error: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , 1) + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvShortcut)) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "getObject", Erl) diff --git a/wizards/source/access2base/PropertiesSet.xba b/wizards/source/access2base/PropertiesSet.xba index 58a3eeaa1952..bdd6dbf76ba3 100644 --- a/wizards/source/access2base/PropertiesSet.xba +++ b/wizards/source/access2base/PropertiesSet.xba @@ -96,6 +96,12 @@ Public Function setDefaultValue(Optional pvObject As Variant, ByVal Optional pvV End Function ' setDefaultValue REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setDescription(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setDescription") + setDescription = PropertiesSet._setProperty(pvObject, "Description", pvValue) +End Function ' setDescription + +REM ----------------------------------------------------------------------------------------------------------------------- Public Function setEnabled(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setEnabled") setEnabled = PropertiesSet._setProperty(pvObject, "Enabled", pvValue) @@ -243,6 +249,24 @@ Public Function setSelected(Optional pvObject As Variant, ByVal Optional pvValue End Function ' setSelected REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelLength(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelLength") + setSelLength = PropertiesSet._setProperty(pvObject, "SelLength", pvValue) +End Function ' setSelLength + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelStart(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelStart") + setSelStart = PropertiesSet._setProperty(pvObject, "SelStart", pvValue) +End Function ' setSelStart + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setSelText(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean + If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSelText") + setSelText = PropertiesSet._setProperty(pvObject, "SelText", pvValue) +End Function ' setSelText + +REM ----------------------------------------------------------------------------------------------------------------------- Public Function setSpecialEffect(Optional pvObject As Variant, ByVal Optional pvValue As Variant) As Boolean If IsMissing(pvObject) Or IsMissing(pvValue) Or IsEmpty(pvObject) Then Call _TraceArguments("setSpecialEffect") setSpecialEffect = PropertiesSet._setProperty(pvObject, "SpecialEffect", pvValue) @@ -390,7 +414,10 @@ Dim ocButton As Variant, iRadioIndex As Integer If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function pvItem.Default = pvValue Case UCase("DefaultValue") - If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJFIELD)) Then Goto Exit_Function + pvItem.DefaultValue = pvValue + Case UCase("Description") + If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function pvItem.DefaultValue = pvValue Case UCase("Enabled") If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function @@ -455,6 +482,15 @@ Dim ocButton As Variant, iRadioIndex As Integer Case UCase("Selected") If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function If IsMissing(pvIndex) Then pvItem.Selected = pvValue Else pvItem.SelectedI(pvValue, pvIndex) + Case UCase("SelLength") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SelLength = pvValue + Case UCase("SelStart") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SelStart = pvValue + Case UCase("SelText") + If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function + pvItem.SelText = pvValue Case UCase("SpecialEffect") If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function pvItem.SpecialEffect = pvValue diff --git a/wizards/source/access2base/Property.xba b/wizards/source/access2base/Property.xba index f7ca59240897..76df18094982 100644 --- a/wizards/source/access2base/Property.xba +++ b/wizards/source/access2base/Property.xba @@ -14,9 +14,10 @@ REM ---------------------------------------------------------------------------- REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- -Private _Type As String ' Must be PROPERTY -Private _Name As String -Private _Value As Variant +Private _Type As String ' Must be PROPERTY +Private _Name As String +Private _Value As Variant +Private _ParentDatabase As Object REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- diff --git a/wizards/source/access2base/Recordset.xba b/wizards/source/access2base/Recordset.xba index b357cbf10959..16fc3a2785b6 100644 --- a/wizards/source/access2base/Recordset.xba +++ b/wizards/source/access2base/Recordset.xba @@ -18,6 +18,7 @@ Private _Type As String ' Must be RECORDSET Private _Name As String ' Unique, generated Private _ParentName As String Private _ParentType As String +Private _ParentDatabase As Object Private _ForwardOnly As Boolean Private _PassThrough As Boolean Private _ReadOnly As Boolean @@ -40,6 +41,7 @@ Private Sub Class_Initialize() _Type = OBJRECORDSET _Name = "" _ParentName = "" + Set _ParentDatabase = Nothing _ParentType = "" _ForwardOnly = False _PassThrough = False @@ -368,6 +370,8 @@ Const cstThisSub = "Recordset.Close" _ReadOnly = False _CommandType = 0 _Command = "" + _ParentName = "" + _ParentType = "" _DataSet = False _BOF = True _EOF = True @@ -378,7 +382,8 @@ Const cstThisSub = "Recordset.Close" _IsClone = False Set RowSet = Nothing If IsMissing(pbRemove) Then pbRemove = True - If pbRemove Then Application.CurrentDb().RecordsetsColl.Remove(_Name) + If pbRemove Then _ParentDatabase.RecordsetsColl.Remove(_Name) + Set _ParentDatabase = Nothing Exit_Function: Utils._ResetCalledSub(cstThisSub) @@ -478,6 +483,7 @@ Dim i As Integer, bFound As Boolean, oFields As Object oObject._CollType = COLLFIELDS oObject._ParentType = OBJRECORDSET oObject._ParentName = _Name + Set oObject._ParentDatabase = _ParentDatabase oObject._Count = UBound(sObjects) + 1 Goto Exit_Function Case VarType(pvIndex) = vbString @@ -501,6 +507,7 @@ Dim i As Integer, bFound As Boolean, oFields As Object Set oObject.Column = oFields.getByName(sObjectName) oObject._ParentName = _Name oObject._ParentType = _Type + Set oObject._ParentDatabase = _ParentDatabase Exit_Function: Set Fields = oObject @@ -511,7 +518,7 @@ Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Trace_NotFound: - TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Field", pvIndex)) + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) @@ -531,6 +538,58 @@ Const cstThisSub = "Recordset.getProperty" End Function ' getProperty REM ----------------------------------------------------------------------------------------------------------------------- +Public Function GetRows(ByVal Optional pvNumRows As variant) As Variant + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "Recordset.GetRows" + Utils._SetCalledSub(cstThisSub) + +Dim vMatrix() As Variant, lSize As Long, iNumFields As Integer, i As Integer + vMatrix() = Array() + If IsMissing(pvNumRows) Then Call _TraceArguments() + If Not Utils._CheckArgument(pvNumRows, 1, Utils._AddNumeric()) Then Goto Exit_Function + If pvNumRows < 1 Then Goto Trace_Error + If IsNull(RowSet) Then Goto Trace_Closed + If Not _DataSet Then Goto Exit_Function + + If _EditMode <> dbEditNone Then CancelUpdate() + + If _EOF Then Goto Exit_Function + + lSize = -1 + iNumFields = RowSet.getColumns().Count - 1 + If iNumFields < 0 Then Goto Exit_Function + + ReDim vMatrix(0 To pvNumRows - 1, 0 To iNumFields) ' Conscious opposite of MSAccess !! + + Do While Not _EOF And lSize < pvNumRows - 1 + lSize = lSize + 1 + For i = 0 To iNumFields + vMatrix(lSize, i) = _getResultSetColumnValue(RowSet, i + 1) + Next i + _Move("NEXT") + Loop + If lSize < pvNumRows - 1 Then ' Resize to number of fetched records + ReDim Preserve vMatrix(0 To lSize, 0 To iNumFields) + End If + +Exit_Function: + GetRows() = vMatrix() + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvNumRows)) + Set Controls = Nothing + Goto Exit_Function +Trace_Closed: + TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) + Goto Exit_Function +End Function ' GetRows V1.1.0 + +REM ----------------------------------------------------------------------------------------------------------------------- Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean ' Return True if object has a valid property called pvProperty (case-insensitive comparison !) @@ -589,7 +648,7 @@ Dim cstThisSub As String Set OpenRecordset = Nothing Const cstNull = -1 -Dim oObject As Object, odbDatabase As Object +Dim oObject As Object Set oObject = Nothing If IsMissing(pvType) Then pvType = cstNull @@ -614,17 +673,17 @@ Dim oObject As Object, odbDatabase As Object ._Command = _Command ._ParentName = _Name ._ParentType = _Type + Set ._ParentDatabase = _ParentDatabase ._ForwardOnly = ( pvType = dbOpenForwardOnly ) ._PassThrough = ( pvOptions = dbSQLPassThrough ) - ._ReadOnly = ( pvLockEdit = dbReadOnly ) + ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly ) Select Case True Case pbClone : Call ._Initialize(, RowSet) Case _Filter <> "" : Call ._Initialize(_Filter) Case Else : Call ._Initialize() End Select End With - Set odbDatabase = Application._CurrentDb() - With odbDatabase + With _ParentDatabase .RecordsetMax = .RecordsetMax + 1 oObject._Name = Format(.RecordsetMax, "0000000") .RecordsetsColl.Add(oObject, UCase(oObject._Name)) @@ -659,6 +718,7 @@ Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If + Set vProperty._ParentDatabase = _ParentDatabase Exit_Function: Set Properties = vProperty @@ -740,7 +800,7 @@ Public Sub _Initialize(ByVal Optional pvFilter As Variant, Optional poRowSet As Set RowSet = CreateUnoService("com.sun.star.sdb.RowSet") _IsClone = False With RowSet - If IsNull(.ActiveConnection) Then Set .ActiveConnection = Application._CurrentDb().Connection ' Error forced if connection broken + If IsNull(.ActiveConnection) Then Set .ActiveConnection = _ParentDatabase.Connection .CommandType = _CommandType .Command = _Command If _ForwardOnly Then .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY _ @@ -1016,7 +1076,7 @@ Dim oObject As Object Case UCase("Filter") If IsNull(RowSet) Then Goto Trace_Closed If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value - _Filter = Utils._ReplaceSquareBrackets(pvValue) + _Filter = _ParentDatabase._ReplaceSquareBrackets(pvValue) Case Else Goto Trace_Error End Select diff --git a/wizards/source/access2base/SubForm.xba b/wizards/source/access2base/SubForm.xba index 0efe7ff05ad0..6f28c8d7dd12 100644 --- a/wizards/source/access2base/SubForm.xba +++ b/wizards/source/access2base/SubForm.xba @@ -15,8 +15,11 @@ REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- Private _Type As String ' Must be SUBFORM +Private _This As Object Private _Shortcut As String Private _Name As String +Private _DocEntry As Integer +Private _DbEntry As Integer Public ParentComponent As Object ' com.sun.star.text.TextDocument Public DatabaseForm As Object ' com.sun.star.form.component.DataForm and com.sun.star.sdb.ResultSet (a.o.) @@ -27,6 +30,8 @@ Private Sub Class_Initialize() _Type = OBJSUBFORM _Shortcut = "" _Name = "" + _DocEntry = -1 + _DbEntry = -1 Set ParentComponent = Nothing Set DatabaseForm = Nothing End Sub ' Constructor @@ -118,19 +123,20 @@ REM ---------------------------------------------------------------------------- Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant ' Return either an error or an object of type OPTIONGROUP based on its name - Utils._SetCalledSub("SubForm.OptionGroup") +Const cstThisSub = "SubForm.OptionGroup" + Utils._SetCalledSub(cstThisSub) If IsMissing(pvGroupName) Then Call _TraceArguments() If _ErrorHandler() Then On Local Error Goto Error_Function - Set OptionGroup = _OptionGroup(pvGroupName, CTLPARENTISSUBFORM, DatabaseForm, ParentComponent) + Set OptionGroup = _OptionGroup(pvGroupName, CTLPARENTISSUBFORM, _This) Exit_Function: - Utils._ResetCalledSub("SubForm.OptionGroup") + Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: - TraceError(TRACEABORT, Err, "SubForm.OptionGroup", Erl) + TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function -End Function ' OptionGroup +End Function ' OptionGroup V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Parent() As Object @@ -245,15 +251,13 @@ Dim j As Integer End If ocControl._Initialize() + ocControl._DocEntry = _DocEntry + ocControl._DbEntry = _DbEntry Set Controls = ocControl Exit_Function: Utils._ResetCalledSub("SubForm.Controls") Exit Function -Trace_Error: - TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , 1) - Set Controls = Nothing - Goto Exit_Function Trace_Error_Index: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) Set Controls = Nothing @@ -266,7 +270,7 @@ Error_Function: TraceError(TRACEABORT, Err, "SubForm.Controls", Erl) Set Controls = Nothing GoTo Exit_Function -End Function ' Controls +End Function ' Controls V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant @@ -409,16 +413,18 @@ Dim oDatabase As Object, vBookmark As Variant, vEMPTY As Variant If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ?? Set oObject = New Recordset With DatabaseForm - oObject._CommandType = DatabaseForm.CommandType - oObject._Command = DatabaseForm.Command + oObject._CommandType = .CommandType + oObject._Command = .Command oObject._ParentName = _Name oObject._ParentType = _Type + Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) + Set oObject._ParentDatabase = oDatabase + Set oObject._ParentDatabase.Connection = .ActiveConnection oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY ) oObject._PassThrough = ( .EscapeProcessing = False ) oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY ) Call oObject._Initialize() End With - Set oDatabase = Application._CurrentDb() With oDatabase .RecordsetMax = .RecordsetMax + 1 oObject._Name = Format(.RecordsetMax, "0000000") @@ -477,14 +483,14 @@ Dim iArgNr As Integer DatabaseForm.absolute(pvValue) Case UCase("Filter") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value - DatabaseForm.Filter = Utils._ReplaceSquareBrackets(pvValue) + DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) Case UCase("FilterOn") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value DatabaseForm.ApplyFilter = pvValue DatabaseForm.reload() Case UCase("RecordSource") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value - DatabaseForm.Command = Utils._ReplaceSquareBrackets(pvValue) + DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND DatabaseForm.Filter = "" DatabaseForm.reload() diff --git a/wizards/source/access2base/Test.xba b/wizards/source/access2base/Test.xba index c96340c1599c..4f64ba243271 100644 --- a/wizards/source/access2base/Test.xba +++ b/wizards/source/access2base/Test.xba @@ -4,14 +4,28 @@ 'Option Compatible Sub Main - Application._RootInit() + 'Application._RootInit() _A2B_.CalledSub = "" Application.SysCmd(acSysCmdRemoveMeter) Dim a as variant, b as variant, c as variant, d as variant, i as integer, s as string,f as variant, h as variant, j as long, k as integer, l as integer, sFile As String -Dim lTime1 as Date, lTime2 as Long +Dim lTime1 as Long, lTime2 as Long lTime1=getsystemticks() ' TraceConsole() - + _ErrorHandler(False) + traceconsole() + exit sub + CurrentDb().CloseAllrecordsets() + Set a = CurrentDb().TableDefs("Alltypes") + Set b = a.OpenRecordset( , , dbreadOnly) +Dim vVar() As Variant + Set vVar = b.GetRows(1000) + b.mClose() + DebugPrint UBound(vVar, 1), UBound(vVar, 2) + For i = 0 To UBound(vVar, 2) + For j = 0 To UBound(vVar, 1) + DebugPrint i, j, vVar(j, i) + Next j + Next i lTime2=getsystemticks debugprint lTime2 - lTime1 exit sub diff --git a/wizards/source/access2base/Trace.xba b/wizards/source/access2base/Trace.xba index 5ceaf865af4d..5017208155bb 100644 --- a/wizards/source/access2base/Trace.xba +++ b/wizards/source/access2base/Trace.xba @@ -35,8 +35,13 @@ Dim sLineBreak As String, oDialogLib As Object, oTraceDialog As Object sLineBreak = Chr(10) Set oDialogLib = DialogLibraries - If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base") - Set oTraceDialog = CreateUnoDialog(DialogLibraries.Access2Base.dlgTrace) + If oDialogLib.hasByName("Access2BaseDev") Then + If Not oDialogLib.IsLibraryLoaded("Access2BaseDev") Then oDialogLib.loadLibrary("Access2BaseDev") + Set oTraceDialog = CreateUnoDialog(DialogLibraries.Access2BaseDev.dlgTrace) + Else + If Not oDialogLib.IsLibraryLoaded("Access2Base") Then oDialogLib.loadLibrary("Access2Base") + Set oTraceDialog = CreateUnoDialog(DialogLibraries.Access2Base.dlgTrace) + EndIf oTraceDialog.Title = _GetLabel("DLGTRACE_TITLE") ' HelpText ??? Dim oEntries As Object, oTraceLog As Object, oClear As Object, oMinLevel As Object, oNbEntries As Object, oDump As Object @@ -138,7 +143,7 @@ Error_Sub: .TraceLogLast = 0 End With GoTo Exit_Sub -End Sub ' TraceConsole V1.0.0 +End Sub ' TraceConsole V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub TraceError(ByVal psErrorLevel As String _ @@ -399,22 +404,4 @@ Dim vTraces As Variant, i As Integer End Function ' TraceLevel -REM ----------------------------------------------------------------------------------------------------------------------- -Public Function _TraceStandalone(ByVal Optional psCall As String) As Boolean -' Display error when property or method or action not applicable from a standalone form -' If 2nd argument = SILENT set silent mode. Silent mode = no error message (for tests purpose only) - -Static sMode As String -Const cstSilent = "SILENT" - If Not IsMissing(psCall) Then - If psCall = cstSilent Then sMode = cstSilent Else Utils._SetCalledSub(psCall) - End If - If Application._CurrentDb()._Standalone Then - If sMode <> cstSilent Then TraceError(TRACEFATAL, ERRSTANDALONE, Utils._CalledSub(), 0) - _TraceStandalone = True - Else - _TraceStandalone = False - End If - -End Function ' TraceStandalone </script:module>
\ No newline at end of file diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba index 93e7ad9da87c..99c3cd883e2c 100644 --- a/wizards/source/access2base/Utils.xba +++ b/wizards/source/access2base/Utils.xba @@ -162,6 +162,29 @@ Public Function _DecimalPoint() As String End Function REM ----------------------------------------------------------------------------------------------------------------------- +Public Function _Dump_A2B() As Variant +' For debugging purposes +Dim i As Integer, j As Integer, vCurrentDoc As Variant + On Local Error Resume Next + With _A2B_ + DebugPrint "Version", .VersionNumber + DebugPrint "TraceLevel", .MinimalTraceLevel + DebugPrint "TraceCount", .TraceLogCount + DebugPrint "CalledSub", .CalledSub + If IsArray(.CurrentDoc) Then + For i = 0 To UBound(.CurrentDoc) + vCurrentDoc = .CurrentDoc(i) + DebugPrint i, "URL", vCurrentDoc.URL + For j = 0 To UBound(vCurrentDoc.DbContainers) + DebugPrint i, j, "Form", vCurrentDoc.DbContainers(j).FormName + DebugPrint i, j, "Database", vCurrentDoc.DbContainers(j).Database.Title + Next j + Next i + End If + End With +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- Private Function _ExtensionLocation() As String ' Return the URL pointing to the location where OO installed the Access2Base extension ' Adapted from http://wiki.services.openoffice.org/wiki/Documentation/DevGuide/Extensions/Location_of_Installed_Extensions @@ -179,40 +202,56 @@ REM get the data for the column specified by ColIndex REM get type name from metadata Dim vValue As Variant, sType As String, vDateTime As Variant +Dim bNullable As Boolean, bNull As Boolean, oValue As Object + On Local Error Goto 0 ' Disable error handler + vValue = Null ' Default value if error sType = poResultSet.MetaData.getColumnTypeName(piColIndex) - Select Case sType - Case "ARRAY": vValue = poResultSet.getArray(piColIndex) - Case "BLOB": vValue = poResultSet.getBlob(piColIndex) - Case "BIT", "BOOLEAN": vValue = poResultSet.getBoolean(piColIndex) - Case "BYTE": vValue = poResultSet.getByte(piColIndex) - Case "BYTES": vValue = poResultSet.getBytes(piColIndex) - Case "CLOB": vValue = poResultSet.getClob(piColIndex) - Case "DATE": vDateTime = poResultSet.getDate(piColIndex) - vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) - Case "DOUBLE", "REAL": vValue = poResultSet.getDouble(piColIndex) - Case "FLOAT": vValue = poResultSet.getFloat(piColIndex) - Case "INTEGER", "SMALLINT": vValue = poResultSet.getInt(piColIndex) - Case "LONG", "BIGINT": vValue = poResultSet.getLong(piColIndex) - Case "DECIMAL", "NUMERIC": vValue = poResultSet.getDouble(piColIndex) - Case "NULL": vValue = poResultSet.getNull(piColIndex) - Case "OBJECT": vValue = poResultSet.getObject(piColIndex) - Case "REF": vValue = poResultSet.getRef(piColIndex) - Case "SHORT", "TINYINT": vValue = poResultSet.getShort(piColIndex) - Case "CHAR", "VARCHAR", "LONGVARCHAR": vValue = poResultSet.getString(piColIndex) - Case "TIME": vDateTime = poResultSet.getTime(piColIndex) - vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) - Case "TIMESTAMP": vDateTime = poResultSet.getTimeStamp(piColIndex) - vValue = DateSerial(CInt(vDateTime.Year), CInt(vDateTime.Month), CInt(vDateTime.Day)) _ - + TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) - Case Else - 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 + With poResultSet + bNullable = ( .MetaData.IsNullable(piColIndex) = com.sun.star.sdbc.ColumnValue.NULLABLE ) + Select Case sType + Case "ARRAY": vValue = .getArray(piColIndex) + Case "BINARY", "VARBINARY", "LONGVARBINARY" + Set oValue = .getBinaryStream(piColIndex) + If bNullable Then bNull = .wasNull() + If Not bNull Then vValue = CLng(oValue.getLength()) ' Return length, not content + oValue.closeInput() + Case "BLOB": vValue = .getBlob(piColIndex) + Case "BIT", "BOOLEAN": vValue = .getBoolean(piColIndex) + Case "BYTE": vValue = .getByte(piColIndex) + Case "BYTES": vValue = .getBytes(piColIndex) + Case "CLOB": vValue = .getClob(piColIndex) + Case "DATE": vDateTime = .getDate(piColIndex) + If bNullable Then bNull = .wasNull() + If Not bNull 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", "LONGVARCHAR": vValue = .getString(piColIndex) + Case "TIME": vDateTime = .getTime(piColIndex) + If bNullable Then bNull = .wasNull() + If Not bNull Then vValue = TimeSerial(vDateTime.Hours, vDateTime.Minutes, vDateTime.Seconds)', vDateTime.HundredthSeconds) + Case "TIMESTAMP": vDateTime = .getTimeStamp(piColIndex) + If bNullable Then bNull = .wasNull() + If Not bNull 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 + If IsNumeric(vValue) Then vValue = Val(vValue) 'Required when type = "", sometimes numeric fields are returned as strings (query/MSAccess) + End Select + If bNullable Then bNull = .wasNull() + If bNull Then vValue = Null + End With _getResultSetColumnValue = vValue -End Function ' getResultSetColumnValue V 0.9.5 +End Function ' getResultSetColumnValue V 1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _FinalProperty(psShortcut As String) As String @@ -339,10 +378,16 @@ Public Function _InList(ByVal pvItem As Variant, pvList As Variant, ByVal Option Dim i As Integer, bFound As Boolean, iListVarType As Integer, iItemVarType As Integer Dim iTop As Integer, iBottom As Integer, iFound As Integer iItemVarType = VarType(pvItem) + If IsMissing(pvReturnValue) Then pvReturnValue = False If iItemVarType = vbNull Or IsNull(pvList) Then _InList = False ElseIf Not IsArray(pvList) Then - _InList = ( pvItem = pvList ) + If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList) ) Else bFound = ( pvItem = pvList ) + If Not pvReturnValue Then + _InList = bFound + Else + If bFound Then _InList = pvList Else _InList = False + End If ElseIf UBound(pvList) < LBound(pvList) Then ' Array not initialized _InList = False Else @@ -358,7 +403,7 @@ Dim iTop As Integer, iBottom As Integer, iFound As Integer If IsMissing(pbBinarySearch) Then pbBinarySearch = False If Not pbBinarySearch Then ' Linear search For i = LBound(pvList) To UBound(pvList) - If iItemVarType = vbString Then bFound = ( pvList(i) <> "" And UCase(pvItem) = UCase(pvList(i)) ) Else bFound = ( pvItem = pvList(i) ) + If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(i)) ) Else bFound = ( pvItem = pvList(i) ) If bFound Then iFound = i Exit For @@ -374,18 +419,18 @@ Dim iTop As Integer, iBottom As Integer, iFound As Integer Else iTop = iFound - 1 End If - If iItemVarType = vbString Then bFound = ( pvList(i) <> "" And UCase(pvItem) = UCase(pvList(iFound)) ) Else bFound = ( pvItem = pvList(iFound) ) + If iItemVarType = vbString Then bFound = ( UCase(pvItem) = UCase(pvList(iFound)) ) Else bFound = ( pvItem = pvList(iFound) ) Loop Until ( bFound ) Or ( iBottom > iTop ) End If If bFound Then - If IsMissing(pvReturnValue) Then _InList = True Else _InList = pvList(iFound) + If Not pvReturnValue Then _InList = True Else _InList = pvList(iFound) End If End If End If Exit Function -End Function ' InList V0.9.0 +End Function ' InList V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _InspectPropertyType(poObject As Object, psProperty As String) As String @@ -438,27 +483,26 @@ Dim bIsPseudo As Boolean, bPseudoExists As Boolean, vObject As Variant If Not bIsPseudo Then Goto Exit_Function -Dim oDatabase As Variant, oForms As Variant +Dim oDoc As Object, oForms As Variant bPseudoExists = False With vObject Select Case ._Type Case OBJFORM If ._Name <> "" Then ' Check validity of form name - Set oDatabase = _CurrentDb - If oDatabase._Standalone Then + Set oDoc = _A2B_.CurrentDoc(Application._CurrentDoc()) + If oDoc.DbConnect = DBCONNECTFORM Then bPseudoExists = True Else - Set oForms = oDatabase.Document.getFormDocuments() + Set oForms = oDoc.Document.getFormDocuments() bPseudoExists = ( oForms.HasByName(._Name) ) End If End If Case OBJDATABASE - If ._Standalone Then bPseudoExists = True Else bPseudoExists = .Document.CurrentController.IsConnected + If ._DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = .Document.CurrentController.IsConnected Case OBJDIALOG If ._Name <> "" Then ' Check validity of dialog name - Set oDatabase = _CurrentDb - bPseudoExists = ( oDatabase._hasDialog(._Name) ) + bPseudoExists = ( Application._hasDialog(._Name) ) End If Case OBJCOLLECTION bPseudoExists = True @@ -499,7 +543,7 @@ Exit_Function: Exit_False: _IsPseudo = False Goto Exit_Function -End Function ' IsPseudo V0.9.1 +End Function ' IsPseudo V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _IsScalar(ByVal pvArg As Variant, Byval pvType As Variant, ByVal Optional pvValid As Variant) As Boolean @@ -545,31 +589,6 @@ Dim vSubStrings() As Variant, i As Integer, iLen As Integer End Function ' PCase V0.9.0 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function _ReplaceSquareBrackets(ByVal psSql As String) As String -' Returns psSql after substitution of [] by quote character -' [] square brackets in quoted strings not affected - -Dim sQuote As String 'RDBMS specific quote character -Dim vSubStrings() As Variant, i As Integer - - sQuote = CurrentDb.MetaData.IdentifierQuoteString - If sQuote = " " Then ' What's the string used to quote SQL identifiers? This returns a space " " if identifier quoting is not supported. - _QuoteString = psSql - Exit Function - End If - vSubStrings() = Split(psSql, sQuote) - For i = 0 To UBound(vSubStrings) - If (i Mod 2) = 0 Then ' Only even substrings are parsed for square brackets - vSubStrings(i) = Join(Split(vSubStrings(i), "["), sQuote) - vSubStrings(i) = Join(Split(vSubStrings(i), "]"), sQuote) - End If - Next i - - _ReplaceSquareBrackets = Join(vSubStrings, sQuote) - -End Function ' ReplaceSquareBrackets V0.7.5 - -REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _ResetCalledSub(ByVal psSub As String) As String ' Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling ' Used to trace routine in/outs and to clarify error messages diff --git a/wizards/source/access2base/acConstants.xba b/wizards/source/access2base/acConstants.xba index 7f5700c536ff..9906c58407ac 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.0.0" +Global Const Access2Base_Version = "1.1.0" REM AcCloseSave REM ----------------------------------------------------------------- @@ -49,9 +49,10 @@ Global Const acForm = 2 Global Const acQuery = 1 Global Const acReport = 3 Global Const acTable = 0 - +' Unexisting in MS/Access Global Const acBasicIDE = 101 Global Const acDatabaseWindow = 102 +Global Const acDocument = 111 REM AcWindowMode REM ----------------------------------------------------------------- |