Hi,
I'm back, Thank you for your response !
The time spent a lot with GetRows call.
OpenRecorset with Move is about
240 ticks, and
GetRows about 3656 ticks...
I tested with 2 configration :
Configuration 01 : Linux Debian (There is a bug with LibreOffice, and I needed to add a patch into the Kernel to use base) :
- Access2Bas recorsdset object with
InitListChoixAccess2Base function :
ticks are about 3890, 3908, 4027, 2952 ...
- LibreOffice native rowset with
InitListChoixBase :
ticks are about 779, 819, 790 ...
Configuration 02 : Windows 7 Professionnel + LibreOffice 5.2.6.2 + HSQLDB 2.4.0
- Access2Bas recorsdset object with
InitListChoixAccess2Base function :
ticks are about 970, 940, 867, 914 ... So It's better than with my Linux Debian !. It's closed to LibreOffice native Rowset call. So it's OK.
CONCLUSION : Finaly, may be the problem will be the patch with Debian Kernel about the security issue and Side effects on LibreOffice...
I publish
working code below. Sorry, there is a lot of tests :
File DlgSelectCotationClassfor the object to manage the dialog :
Code: Select all
REM ***** BASIC *****
Option Compatible
Option ClassModule
Option Explicit
Option Base 0
Rem ------------------------------------------------------------
Rem
Rem VARIABLES PRIVEES
Rem
Rem ------------------------------------------------------------
Global _ThisDlgSingleton As Object
Global _oRecordset As Object
Global _ArrayListChoix(1) As String
Global vVarRecords As Variant
Rem ------------------------------------------------------------
Rem
Rem CONSTRUTEUR / DESTRUCTEUR
Rem
Rem ------------------------------------------------------------
Private Sub Class_Initialize()
End Sub
Private Sub Class_Terminate()
End Sub
Rem ------------------------------------------------------------
Rem
Rem CLASS GET/LET/SET PROPERTIES
Rem
Rem ------------------------------------------------------------
Rem ------------------------------------------------------------
Rem Get ArrayListChoix
Rem
Public Property Get SelectedCotation As String
Dim SItem As String
Dim pos As Integer
On Error goto Erreur :
Debug_Trace(Name, "SelectedItem")
SItem = _ThisDlgSingleton.getControl("ListBoxClasses").SelectedItem
Debug_Trace(Name, "InStr")
pos = InStr(1,SItem,":",1)
Debug_Trace(Name, "SelectedCotation")
SelectedCotation = Mid(SItem, 1, pos-1)
Debug_Trace(Name, "Fin")
Exit Property
Erreur:
Debug_Catch(Name, "SelectedCotation")
End Property
Rem ------------------------------------------------------------
Rem
Rem METHODES DE CLASSE
Rem
Rem ------------------------------------------------------------
Rem ------------------------------------------------------------
Rem InitListChoixAccess2Base
Rem
Private Function InitListChoixAccess2Base(FKFonds As Integer, Optional SFilter As String) As Array
Dim RowNumber, numRows As Integer
Dim t As Long
On Error goto Erreur :
Rem Initialisation du plan de classement ...
Rem if not isEmpty(_ArrayListChoix) > 1 Then
Rem Debug_Trace(Name, "ARRAYLISTCHOIX ALREADY GO")
Rem InitListChoixAccess2Base = _ArrayListChoix
Rem Exit Function
Rem End If
Rem Debug_Trace(Name, "OPENRECORDSET(...)")
Rem t = GetSystemTicks
Set _oRecordset = Application.CurrentDb().OpenRecordset("SELECT CONCAT([INDICE], ' : ', [CLASSE]) AS INDICECLASSE" & _
" FROM [IDXLESCLASSESPC], [AUTLESFONDSDOCUMENTAIRES]" & _
" WHERE [AUTLESFONDSDOCUMENTAIRES].[ID] = " & FKFonds & _
" AND [IDXLESCLASSESPC].[FKPLAN] = [AUTLESFONDSDOCUMENTAIRES].[FKPLANCLASSEMENT] ORDER BY INDICE ASC",,,dbReadOnly) Rem dbOpenForwardOnly
With _oRecordset
Rem Debug_Trace(Name, ".Filter")
if not IsMissing(SFilter) Then .Filter = SFilter
Rem Debug_Trace(Name, ".SetOrderBy")
Rem .SetOrderBy = "INDICE ASC"
Rem Debug_Trace(Name, ".MoveLast/first")
.MoveLast()
Rem t = GetSystemTicks - t
Rem MsgBox("Nombre de ticks OpenRecordset + MoveLast : " & t)
.MoveFirst()
Rem Debug_Trace(Name, ".GetRows")
Rem t = GetSystemTicks
Set vVarRecords = .GetRows(1024)
Rem t = GetSystemTicks - t
Rem MsgBox("Nombre de ticks GetRows : " & t)
Rem Debug_Trace(Name, "numRows = ...")
numRows = UBound(vVarRecords,2) Rem + 1
Rem Fetch recordsets to _ArrayListChoix
Rem Debug_Trace(Name, "Redim _ArrayListChoix(" & numRows + 1 & ")")
Redim _ArrayListChoix(numRows+1) As String
Rem Debug_Trace(Name, "Fetch des recordsets dans _ArrayListChoix")
RowNumber = 0
Do while RowNumber < numRows
_ArrayListChoix(RowNumber) = vVarRecords(0, RowNumber) Rem .Fields("INDICECLASSE").Value
RowNumber = RowNumber + 1
Loop
.mClose()
End With
Rem Trace _ArrayListChoix
Rem RowNumber = 0
Rem Do while RowNumber < numRows
Rem Debug_Trace(Name, _ArrayListChoix(RowNumber))
Rem RowNumber = RowNumber + 1
Rem Loop
Rem Debug_Trace(Name, "Affectation de la valeur retour InitListChoixAccess2Base")
InitListChoixAccess2Base = _ArrayListChoix
Exit Function
Erreur:
Debug_Catch(Name, "InitListChoixAccess2Base")
End Function
Rem ------------------------------------------------------------
Rem InitListChoixBase
Rem
Private Function InitListChoixBase(FKFonds As Integer, Optional SFilter As String) As Array
Dim RowSet As Object
Dim I As Integer
Dim upperbound As Variant
Set RowSet = CreateUnoService("com.sun.star.sdb.RowSet")
With RowSet
.DataSourceName=ConvertToURL("/home/#####/TypodocOOoHSQLDBclient.odb") rem
.CommandType=com.sun.star.sdb.CommandType.COMMAND
.command="SELECT CONCAT(INDICE, ' : ', CLASSE) AS INDICECLASSE" & _
" FROM IDXLESCLASSESPC, AUTLESFONDSDOCUMENTAIRES" & _
" WHERE AUTLESFONDSDOCUMENTAIRES.ID=" & FKFonds & _
" AND IDXLESCLASSESPC.FKPLAN=AUTLESFONDSDOCUMENTAIRES.FKPLANCLASSEMENT"
if not IsMissing(SFilter) Then .command = .command & SFilter
.command = .command & " ORDER BY INDICE"
.execute()
End With
RowSet.last() : RowSet.First()
Rem Fetch du plan de classement
Rem SingeltonListBox.RemoveItems(0,ControlListBoxClasses.ItemCount)
Rem Le rang des items commence à 0
upperbound = RowSet.RowCount
Redim _ArrayListChoix(upperbound) As String
I = 0
RowSet.BeforeFirst()
While RowSet.Next
_ArrayListChoix(I) = RowSet.Columns.getByName("INDICECLASSE").String
I = I + 1
Wend
InitListChoixBase = _ArrayListChoix
End Function
Rem ------------------------------------------------------------
Rem SelectFondsAndFilter
Rem
Private Sub UpdateEtat(FKFonds As Integer)
Dim RowSet As Object
Dim CtrlTxtEtat As Object
Rem Actualiser la barre d'état avec le nom du plan de classement courrant
Set CtrlTxtEtat = _ThisDlgSingleton.getControl("CtlTxtEtatPlanClassement")
Set RowSet = CreateUnoService("com.sun.star.sdb.RowSet")
With RowSet
.DataSourceName=ConvertToURL("/home/gelinp/04_PROGRAMATION/projets/TypodocOoo/TypodocOOoHSQLDBclient.odb")
.CommandType=com.sun.star.sdb.CommandType.COMMAND
.command="SELECT PLAN FROM AUTLESFONDSDOCUMENTAIRES, AUTLESPLANSCLASSEMENT " & _
" WHERE AUTLESFONDSDOCUMENTAIRES.ID = " & FKFonds & _
" AND FKPLANCLASSEMENT = AUTLESPLANSCLASSEMENT.ID"
.execute()
End With
RowSet.last() : RowSet.First()
Rem Actauliser la barre d'état avec le nombre de classes du plan de classement courrant
CtrlTxtEtat.Text = "Plan de classement : " & RowSet.Columns.getByName("PLAN").String
With RowSet
.command="SELECT COUNT(IDXLESCLASSESPC.ID) AS NBCLASSES FROM AUTLESFONDSDOCUMENTAIRES, IDXLESCLASSESPC " & _
" WHERE AUTLESFONDSDOCUMENTAIRES.ID = " & FondsCourrent & _
" AND IDXLESCLASSESPC.FKPLAN = AUTLESFONDSDOCUMENTAIRES.FKPLANCLASSEMENT"
.execute()
End With
RowSet.last() : RowSet.First()
CtrlTxtEtat.Text = CtrlTxtEtat.Text & " [ " & RowSet.Columns.getByName("NBCLASSES").String & " classes ]"
End Sub
Rem ------------------------------------------------------------
Rem Open
Rem
Function OpenDialog(FKfonds As Integer) As Integer
Const DlgName = "DlgSelectCotation"
Const LibraryName = "Standard"
Dim Library As OBject
Dim ObjDlgTemp As Object
Dim CtrlList As OBject
Dim t As Long
On Error goto Erreur :
Rem --------------------------------------
Rem Etape 1 : Chargement de la boite de dialogue
If Not(DialogLibraries.hasByName(LibraryName)) Then
MsgBox "Erreur : Impossible de trouver la librairie '" & LibraryName & "'"
Exit Function
End If
DialogLibraries.LoadLibrary(LibraryName)
Set Library = DialogLibraries.getByName(LibraryName)
If Not (Library.hasByName(DlgName)) Then
MsgBox "Erreur : Impossible de trouver la boite de dialogue '" & DlgName & "'"
Exit Function
End If
Set ObjDlgTemp = Library.getByName(DlgName)
Set _ThisDlgSingleton = CreateUnoDialog(ObjDlgTemp)
Debug_Assert(Name, not IsNull( _ThisDlgSingleton), 13, "OpenDialog 01")
Set CtrlList = _ThisDlgSingleton.getControl("ListBoxClasses")
Debug_Assert(Name, not isNull(CtrlList), 13, "OpenDialog 02")
t = GetSystemTicks
CtrlList.Model.StringItemList = InitListChoixBase(FKfonds)
t = GetSystemTicks - t
MsgBox("Nombre de ticks InitListChoixBase = " & t)
Rem UpdateEtat(FKfonds)
OpenDialog = _ThisDlgSingleton.execute()
Exit Function
Erreur:
Debug_Catch(Name, "OpenDialog")
End Function
Rem ------------------------------------------------------------
Rem Close
Rem
Public Sub CloseDialog()
Dim CtrlList As Object
On Error goto Erreur :
Set CtrlList = _ThisDlgSingleton.getControl("ListBoxClasses")
CtrlList.Model.StringItemList = Array(1)
_ThisDlgSingleton.Dispose
Exit Sub
Erreur:
Debug_Catch(Name, "CloseDialaog")
End Sub
Rem ------------------------------------------------------------
Rem Bouton_Filtrer
Rem
Public Sub Bouton_Filtrer(Event As Object)
Dim CtlTxtIndiceFilter As Object
Dim CtlTxtClassFilter As OBject
Dim CtrlList As Object
Dim TxtIndiceFilter, TxtClassFilter, SFilter As String
Dim vVarRecords As Variant
Dim RowNumber, numRows As Integer
Rem Build String filter
Set CtlTxtIndiceFilter = _ThisDlgSingleton.getControl("CtlTxtIndiceFilter")
Set CtlTxtClassFilter = _ThisDlgSingleton.getControl("CtlTxtClassFilter")
Set CtrlList = _ThisDlgSingleton.getControl("ListBoxClasses")
TxtIndiceFilter = Trim(CtlTxtIndiceFilter.Text)
TxtClassFilter = Trim(CtlTxtClassFilter.Text)
CtlTxtIndiceFilter.Text = TxtIndiceFilter
CtlTxtClassFilter.Text = TxtClassFilter
If TxtIndiceFilter Like "\**" Then TxtIndiceFilter = "*"
If TxtClassFilter Like "\**" Then TxtClassFilter = "*"
SFilter = ""
if (Len(TxtIndiceFilter) > 0 AND StrComp(TxtIndiceFilter,"*") <> 0) _
OR (Len(TxtClassFilter) > 0 AND StrComp(TxtClassFilter,"*") <> 0) Then
SFilter = "IDXLESCLASSESPC.INDICE LIKE '" & TxtIndiceFilter & "*'" & _
" AND IDXLESCLASSESPC.CLASSE LIKE '*" & TxtClassFilter
if Len(TxtClassFilter) > 0 Then SFilter = SFilter & "*"
SFilter = SFilter & "'"
EndIf
Rem ReOpen Recordset with Filter and update _ArrayListChoix
With _oRecordset
.Filter = SFilter
.OpenRecorset() Rem apply filter
Rem get array of records
Set vVarRecords = .GetRows(1024)
numRows = UBound(vVarRecords,2) + 1
Rem copy records to ArraylistChoix
Redim _ArrayListChoix(numRows) As String
RowNumber = 0
Do while RowNumber < numRows
_ArrayListChoix(RowNumber) = vVarRecords(0, RowNumber) Rem .Fields("INDICECLASSE").Value
RowNumber = RowNumber + 1
Loop
.mClose()
End With
CtrlList.Model.StringItemList = _ArrayListChoix
End Sub
File to test and debug
Code: Select all
Rem ***************************************************
Rem p 181 : Fichiers
Rem p 190 : mécanismes interception erreurs
Rem p194 : Code d'erreur OooBasic
Rem ***************************************************
Option Explicit
Global CONST DEBUG = true
Global FichierDebugExiste As Boolean 'default = false
CONST NomFichier = "/home/gelinp/04_PROGRAMATION/projets/TypodocOoo/log.txt"
Rem ***************************************************
Rem TEST UNITAIRE
Rem ***************************************************
Sub Main
On Error goto Erreur :
Debug_Trace(Name, "Hello World !")
Debug_Trace(Name, ThisDatabaseDocument.URL)
Debug_Assert(Name, false, 13, "Assert n°1")
Exit Sub
Erreur:
Debug_Catch(Name, "Main")
End Sub
Rem ***************************************************
Rem Debug_Fabrique
Rem ***************************************************
Function Debug_Fabrique As Integer
Dim f1 As Integer
On Error goto Erreur
if (not DEBUG) then
Debug_Fabrique = 0
Exit Function
endif
f1 = FreeFile
if (not FichierDebugExiste) Then
Rem Fichier ouvert pour (re)écriture avec effacement
Rem du contenu précédent
Open NomFichier For Output As #f1
FichierDebugExiste = true
Write #f1, " *** DEBUT DU MODE DEBUG *** / Date-heure : " & Now
else
Open NomFichier For Append As #f1
Endif
Debug_Fabrique = f1
Exit Function
Erreur:
FichierDebugExiste = false
Debug_Fabrique = O
print "Problème de création du fichier debug !!"
End Function
Rem ***************************************************
Rem Debug_Close
Rem ***************************************************
Sub Debug_Close(f1 As Integer)
On Error Resume Next
if not DEBUG then exit Sub
Rem Ferme le fichier de traces
Close #f1
End Sub
Rem ***************************************************
Rem Debug_Catch
Rem ***************************************************
Sub Debug_Catch(Module As String, Appelant As String)
Dim f1 As Integer
On Error Resume Next
if not DEBUG then exit Sub
f1 = Debug_Fabrique
Write #f1, "[" & Module & "::" & Appelant & "] CATCH : Ligne " & _
Erl & ", Erreur n° : " & Err & " - " & Error
Debug_Close(f1)
End Sub
Rem ***************************************************
Rem Debug_Trace
Rem ***************************************************
Sub Debug_Trace(Module As String, Trace as String)
Dim f1 As Integer
On Error Resume Next
if not DEBUG then exit Sub
f1 = Debug_Fabrique
Write #f1, "[" & Module & "] TRACE : " & Trace
Debug_Close(f1)
End Sub
Rem ***************************************************
Rem Debug_Assert
Rem ***************************************************
Sub Debug_Assert(Module As String, Test As Boolean, CodeErr As Integer, Flag As String)
Dim f1 As Integer
On Error Resume Next
if not DEBUG then exit Sub
if not Test Then
f1 = Debug_Fabrique
Write #f1, "[" & Module & "] ASSERTION FAILED ( " & Flag & " )"
Debug_Close(f1)
Err CodeErr
Else
f1 = Debug_Fabrique
Write #f1, "[" & Module & "] ASSERTION SUCCESS ( " & Flag & " )"
Debug_Close(f1)
Endif
End Sub