wizards/source/access2base/Application.xba | 7 - wizards/source/access2base/Database.xba | 2 wizards/source/access2base/DoCmd.xba | 157 +++++++++++++++++++++++++++++ wizards/source/access2base/L10N.xba | 4 wizards/source/access2base/Root_.xba | 8 - wizards/source/access2base/acConstants.xba | 2 6 files changed, 167 insertions(+), 13 deletions(-)
New commits: commit a65308f307554cfd277f24af66df246814ad1b8b Author: Jean-Pierre Ledure <[email protected]> Date: Sat Nov 1 15:33:30 2014 +0100 Access2Base - new ApplyFilter and SetOrderBy actions Those actions are meaningful when applied on Table and Query datasheets. Forms and subforms (1 level) supported as well. Change-Id: Ic104559d84ff94f1e7e9bed3db1a13a286953314 diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba index 441e2ee..162575c 100644 --- a/wizards/source/access2base/Application.xba +++ b/wizards/source/access2base/Application.xba @@ -70,6 +70,7 @@ Global Const ERRQUERYDEFDELETED = 1549 Global Const ERRTABLEDEFDELETED = 1550 Global Const ERRTABLECREATION = 1551 Global Const ERRFIELDCREATION = 1552 +Global Const ERRSUBFORMNOTFOUND = 1553 REM ----------------------------------------------------------------------------------------------------------------------- Global Const DBCONNECTBASE = 1 ' Connection from Base document (OpenConnection) @@ -1185,9 +1186,11 @@ Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional 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 oCurrentDb As Object If IsEmpty(_A2B_) Then GoTo Trace_Error - If IsMissing(piDocEntry) Then Set _CurrentDb = Application.CurrentDb() _ - Else Set _CurrentDb = _A2B_._CurrentDb(piDocEntry, piDbEntry) + If IsMissing(piDocEntry) Then Set oCurrentDb = Application.CurrentDb() _ + Else Set oCurrentDb = _A2B_._CurrentDb(piDocEntry, piDbEntry) + If IsNull(oCurrentDb) Then Goto Trace_Error Else Set _CurrentDb = oCurrentDb Exit_Function: Exit Function diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba index d6b84c1..a8fd3e2 100644 --- a/wizards/source/access2base/Database.xba +++ b/wizards/source/access2base/Database.xba @@ -545,7 +545,7 @@ Const cstNull = -1 If IsMissing(pvOption) Then pvOption = cstNull Else - If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function + If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(dbSQLPassThrough, cstNull)) Then Goto Exit_Function End If If _DbConnect <> DBCONNECTBASE And _DbConnect <> DBCONNECTFORM Then Goto Error_NotApplicable diff --git a/wizards/source/access2base/DoCmd.xba b/wizards/source/access2base/DoCmd.xba index b88dcef..b1c06e1 100644 --- a/wizards/source/access2base/DoCmd.xba +++ b/wizards/source/access2base/DoCmd.xba @@ -37,6 +37,66 @@ REM VBA allows call to actions with missing arguments e.g. OpenForm("aaa&qu REM in StarBasic IsMissing requires Variant parameters REM ----------------------------------------------------------------------------------------------------------------------- +Public Function ApplyFilter( _ + ByVal Optional pvFilter As Variant _ + , ByVal Optional pvSQL As Variant _ + , ByVal Optional pvControlName As Variant _ + ) As Boolean +' Set filter on open table, query, form or subform (if pvControlName present) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "ApplyFilter" + Utils._SetCalledSub(cstThisSub) + ApplyFilter = False + + If IsMissing(pvFilter) And IsMissing(pvSQL) Then Call _TraceArguments() + If IsMissing(pvFilter) Then pvFilter = "" + If Not Utils._CheckArgument(pvFilter, 1, vbString) Then Goto Exit_Function + If IsMissing(pvSQL) Then pvSQL = "" + If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function + If IsMissing(pvControlName) Then pvControlName = "" + If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function + +Dim sFilter As String, oWindow As Object, oDatabase As Object, oTarget As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + If pvSQL <> "" _ + Then sFilter = oDatabase._ReplaceSquareBrackets(pvSQL) _ + Else sFilter = oDatabase._ReplaceSquareBrackets(pvFilter) + + Set oWindow = _SelectWindow() + With oWindow + Select Case .WindowType + Case acForm + Set oTarget = _DatabaseForm(._Name, pvControlName) + Case acQuery, acTable + If pvControlName <> "" Then Goto Exit_Function + Set oTarget = oWindow.Frame.Controller.FormOperations.Cursor + Case Else ' Ignore action + Goto Exit_Function + End Select + End With + + With oTarget + .Filter = sFilter + .ApplyFilter = True + .reload() + End With + ApplyFilter = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' ApplyFilter V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- Public Function mClose(Optional ByVal pvObjectType As Variant _ , Optional ByVal pvObjectName As Variant _ , Optional ByVal pvSave As Variant _ @@ -1768,6 +1828,59 @@ Error_Function: End Function ' SetHiddenAttribute V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- +Public Function SetOrderBy( _ + ByVal Optional pvOrder As Variant _ + , ByVal Optional pvControlName As Variant _ + ) As Boolean +' Sort ann open table, query, form or subform (if pvControlName present) + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "SetOrderBy" + Utils._SetCalledSub(cstThisSub) + SetOrderBy = False + + If IsMissing(pvOrder) Then pvOrder = "" + If Not Utils._CheckArgument(pvOrder, 1, vbString) Then Goto Exit_Function + If IsMissing(pvControlName) Then pvControlName = "" + If Not Utils._CheckArgument(pvControlName, 1, vbString) Then Goto Exit_Function + +Dim sOrder As String, oWindow As Object, oDatabase As Object, oTarget As Object + Set oDatabase = Application._CurrentDb() + If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable + + sOrder = oDatabase._ReplaceSquareBrackets(pvOrder) + + Set oWindow = _SelectWindow() + With oWindow + Select Case .WindowType + Case acForm + Set oTarget = _DatabaseForm(._Name, pvControlName) + Case acQuery, acTable + If pvControlName <> "" Then Goto Exit_Function + Set oTarget = oWindow.Frame.Controller.FormOperations.Cursor + Case Else ' Ignore action + Goto Exit_Function + End Select + End With + + With oTarget + .Order = sOrder + .reload() + End With + SetOrderBy = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRACTION, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +End Function ' SetOrderBy V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- Public Function ShowAllrecords() As Boolean ' Removes any existing filter that exists on the current table, query or form @@ -1825,6 +1938,50 @@ Dim bFound As Boolean End Function ' _CheckColumnType V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _DatabaseForm(psForm As String, psControl As String) +'Return DatabaseForm element of Form object (based on psForm which is known as a real form name) +'or of SubForm object (based on psControl which is checked for being a subform) + +Dim oForm As Object, oControl As Object, sControls() As String, iControlCount As Integer +Dim bFound As Boolean, i As Integer, sName As String + + Set oForm = Application.Forms(psForm) + If psControl <> "" Then ' Search subform + With oForm.DatabaseForm + iControlCount = .getCount() + bFound = False + If iControlCount > 0 Then + sControls() = .getElementNames() + sName = UCase(Utils._Trim(psControl)) + For i = 0 To iControlCount - 1 + If UCase(sControls(i)) = sName Then + bFound = True + Exit For + End If + Next i + End If + End With + If bFound Then sName = sControls(i) Else Goto Trace_NotFound + Set oControl = oForm.Controls(sName) + If oControl._SubType <> CTLSUBFORM Then Goto Trace_SubFormNotFound + Set _DatabaseForm = oControl.Form.DatabaseForm + Else + Set _DatabaseForm = oForm.DatabaseForm + End If + +Exit_Function: + Exit Function +Trace_NotFound: + TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm)) + Goto Exit_Function +Trace_SubFormNotFound: + TraceError(TRACEFATAL, ERRSUBFORMNOTFOUND, Utils._CalledSub(), 0, , Array(psControl, psForm)) + Goto Exit_Function +End Function ' _DatabaseForm V1.2.0 + + + +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 diff --git a/wizards/source/access2base/L10N.xba b/wizards/source/access2base/L10N.xba index 3ec24d2..fce1cee 100644 --- a/wizards/source/access2base/L10N.xba +++ b/wizards/source/access2base/L10N.xba @@ -76,6 +76,7 @@ Dim sLocal As String 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 "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Subform '%0' not found in parent form '%1'" '---------------------------------------------------------------------------------------------------------------------- Case "OBJECT" : sLocal = "Object" Case "TABLE" : sLocal = "Table" @@ -144,7 +145,7 @@ Dim sLocal As String Case "ERR" & ERRINDEXVALUE : sLocal = "Indice invalide ou dimension erronée du tableau pour la propriété '%0'" Case "ERR" & ERRCOLLECTION : sLocal = "Indice de tableau invalide" Case "ERR" & ERRPROPERTYNOTARRAY : sLocal = "L'argument n°%0 doit être un tableau" - Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Contrôle '%0' non trouvé dans le parent (formulaire ou contrôle de table) '%1'" + Case "ERR" & ERRCONTROLNOTFOUND : sLocal = "Contrôle '%0' non trouvé dans le parent (formulaire, contrôle de table ou dialogue) '%1'" Case "ERR" & ERRNOACTIVEFORM : sLocal = "Pas de formulaire ou de contrôle actif" Case "ERR" & ERRDATABASEFORM : sLocal = "Le formulaire '%0' n'a pas de données sous-jacentes" Case "ERR" & ERRFOCUSINGRID : sLocal = "Contrôle '%0' non trouvé dans le contrôle de table '%1'" @@ -181,6 +182,7 @@ Dim sLocal As String 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 "ERR" & ERRSUBFORMNOTFOUND : sLocal = "Sous-formulaire '%0' non trouvé dans le formulaire parent '%1'" '---------------------------------------------------------------------------------------------------------------------- Case "OBJECT" : sLocal = "Objet" Case "TABLE" : sLocal = "Table" diff --git a/wizards/source/access2base/Root_.xba b/wizards/source/access2base/Root_.xba index 052fbce..cee811b 100644 --- a/wizards/source/access2base/Root_.xba +++ b/wizards/source/access2base/Root_.xba @@ -183,14 +183,6 @@ Const cstBase = "com.sun.star.comp.dba.ODatabaseDocument" With CurrentDoc(0) If Not .Active Then GoTo Trace_Error If IsNull(.Document) Then GoTo Trace_Error - If Not Utils._hasUNOProperty(ThisComponent, "URL") Then Goto Trace_Error - If Utils._ImplementationName(ThisComponent) <> cstBase Or .Document.URL <> ThisComponent.URL Then ' Give the parent a try - If Not Utils._hasUNOProperty(ThisComponent, "Parent") Then Goto Trace_Error - If IsNull(ThisComponent.Parent) Then Goto Trace_Error - If Utils._ImplementationName(ThisComponent.Parent) <> cstBase Then Goto Trace_Error - If Not Utils._hasUNOProperty(ThisComponent.Parent, "URL") Then Goto Trace_Error - If .Document.URL <> ThisComponent.Parent.URL Then Goto Trace_Error - End If End With CurrentDocIndex = 0 End If diff --git a/wizards/source/access2base/acConstants.xba b/wizards/source/access2base/acConstants.xba index 5f533fe..fab9789 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.1.0h" +Global Const Access2Base_Version = "1.2.0" REM AcCloseSave REM -----------------------------------------------------------------
_______________________________________________ Libreoffice-commits mailing list [email protected] http://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
