[Libreoffice-commits] core.git: wizards/source
Jean-Pierre Ledure
jp at ledure.be
Sat Nov 1 07:35:11 PDT 2014
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 <jp at ledure.be>
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 -----------------------------------------------------------------
More information about the Libreoffice-commits
mailing list