Deux problèmes récurent dans les macros et transversal à l'ensemble des modules OpenOffice est l'emploi d'un singleton et l'utilisation d'un mutex pour gérer les évènements. Malgré ma consultation de plusieurs livres sur la programmation LibreOffice, OpenOffice je n'ai pas encore trouvé de solution qui s'impose sur ces deux sujets, et rien encore non plus dans le fil de discussion "Suprême de code"...
Je communique ci-dessous mon algorithme pour gérer un mutex, mais je cherche quelque chose de mieux car celui-ci est encore bien perfectible, il a tendance à bloquer l'interface... Surtout si une macro quitte sur une erreur avant de débloquer le mutex... L'exécution suivante est alors complètement bloquée, et il faut redémarrer l'application ...
Module TMutex : Ce module utilise également le module TDictionnaire listé ci-dessous. Le principe du module TMutex est de pouvoir employer plusieurs mutex simultanément pour gérer l'application, chacun associé à une clé dans un pseudo objet TDictionnaire. Le Mutex fonctionne avec une double réservation : un mutex interne pour gérer la concurrence d'accès aux méthodes du pseudo objet TMutex lui même et un mutex extern, répondant à la demande de l'appelant qui demande le verrouillage d'une section de code.
Code : Tout sélectionner
REM ***** BASIC *****
Option Compatible
Option ClassModule
Option Explicit
Dim _ChienMax As Long
Dim _Step As Long
DIm _oDictFlags As Object
Rem ===========================================================================
Rem CONSTRUCTEUR / DESCTRUCTEUR
Rem ===========================================================================
' #PROCEDURE# ==================================================================
' Name...........: Class_Initialize
' Description ...:
' Parameters ....:
' Syntax ........: TransiterEtat(NouvelEtat)
' NouvelEtat - Etat à atteindre
' Return values .: Success - void
' Failure - sets @error
' |1 - NouvelEtat n'est pas un etat valide
' |2 - La transition n'est pas autorisée
' Author ........: Patrick
' Modified.......: - code cleanup
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Private Sub Class_Initialize()
On local error goto Erreur
SgtDebug.Trace(Name, "Class_Initialize()", TRACE_FLAG)
_Step = 80 '80 millisecondes
_ChienMax = 100 '100*80 = 8 secondes, une eternité pour l'utilisateur ...
_oDictFlags = New TDictionnaire
_oDictFlags.Ajouter("FlagMutex", false)
SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)", TRACE_FLAG)
SgtDebug.Assert(Name, _oDictFlags.Contient("FlagMutex"), 12, "Class_Initialize::_oDictFlags.Contient(FlagMutex)", TRACE_FLAG)
Exit_Sub:
On error resume next
Exit Sub
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name, "EstLibre")
Resume Exit_Sub
End Sub
' #PROCEDURE# ==================================================================
' Name...........: Class_Terminate()
' Description ...:
' Parameters ....:
' Syntax ........: TransiterEtat(NouvelEtat)
' NouvelEtat - Etat à atteindre
' Return values .: Success - void
' Failure - sets @error
' |1 - NouvelEtat n'est pas un etat valide
' |2 - La transition n'est pas autorisée
' Author ........: Patrick
' Modified.......: - code cleanup
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Private Sub Class_Terminate()
SgtDebug.Trace(Name, "Class_Terminate()", TRACE_FLAG)
Erase _oDictFlags
End Sub
Rem ===========================================================================
Rem PROPRIETES
Rem ===========================================================================
' #PROCEDURE# ==================================================================
' Name...........: ChienMax
' Description ...:
' Parameters ....:
' Syntax ........:
' Return values .: Success - void
' Author ........: Patrick
' Modified.......: - code cleanup
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Property Let ChienMax(chienmax As Long)
_ChienMax = chienmax
End Property
' #PROCEDURE# ==================================================================
' Name...........: StepWait
' Description ...:
' Parameters ....:
' Syntax ........:
' Return values .: Success - void
' Author ........: Patrick
' Modified.......: - code cleanup
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Property Let StepWait(milliseconds As Long)
_Step = milliseconds
End Property
' #PROCEDURE# ==================================================================
' Name...........: NBElements
' Description ...:
' Parameters ....:
' Syntax ........:
' Return values .: Success - void
' Author ........: Patrick
' Modified.......: - code cleanup
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Property Get NBElements As Long
On local error goto Erreur
NBElements = _oDictFlags.NBElements
Exit_Property:
On error resume next
Exit Property
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name, "NBElements")
Resume Exit_Property
End Property
Rem ===========================================================================
Rem METHODES PRIVEES
Rem ===========================================================================
' #PROCEDURE# ==================================================================
' Name...........: _Verrouiller
' Portée.........: PRIVE
' Description ...: Verrouille l'utilisation interne de l'objet Mutex (aucune autre
' méthode ne peut être appelée, de façon à garantir l'intégrité
' de l'état interne du Mutex). Le Mutex est un singleton, donc
' une ressource partagée qui ne oblige un accès séquentiel. Le
' temps d'attente est fixé par _Step * ChienDeGarde. Pendant le
' temps _Step le thread en attente est complètement endormi...
' Parameters ....: label : Un label assoccié au verrouillage (utile pour le fichier
' de logs)
' Syntax ........:
' Author ........: Patrick
' Modified.......: 30/01/2018
' Remarks .......: En cas d'abandon le trhead est stoppé, ce qui pourrait poser
' problème si l'évènement n'est pas reproduit quelques temps
' après.
' Related .......: Verouiller : Verouille une méthode externe au mutex.
' Link ..........:
' Example .......: _Verrouiller("blocage par appelant ####")
Private Sub _Verrouiller(Optional Label As String)
Dim ChienDeGarde As integer
On error goto Erreur
SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)", TRACE_FLAG)
SgtDebug.Assert(Name, _oDictFlags.Contient("FlagMutex"), 12, "_Verrouiller::_oDictFlags.Contient(FlagMutex)", TRACE_FLAG)
SgtDebug.Trace(Name, "*** DEMANDE BLOQUANTE DU VERROU INTERNE ***", TRACE_EVENT)
'Si FlagMutex = true alors le mutex est verouillé, il faut attendre le retour de FlagMutex = false
ChienDeGarde = 1
Dim flagmutex As Boolean
flagmutex = _oDictFlags.Item("FlagMutex")
While flagmutex AND (ChienDeGarde < _ChienMax)
SgtDebug.Trace(Name, " ... ", TRACE_EVENT)
Wait(_Step)
ChienDeGarde = ChienDeGarde + 1
Wend
If ChienDeGarde = _ChienMax Then
SgtDebug.Trace(Name, "*** ABANDON DE LA DEMANDE DU VERROU INTERNE ! (" & Label & ") ***", TRACE_EVENT)
Stop
EndIf
_oDictFlags.Actualiser("FlagMutex", true)
SgtDebug.Trace(Name, "*** VERROU INTERNE ACTIVE (" & Label & ") ***", TRACE_EVENT
Exit_Sub:
On error resume next
Exit Sub
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name, "_Verrouiller()")
Resume Exit_Sub
End Sub
' #PROCEDURE# ==================================================================
' Name...........: _Liberer
' Portée.........: PRIVE
' Description ...: Libère le verrou interne du Mutex
' Parameters ....: label : Un label assoccié au verrouillage (utile pour le fichier
' de logs)
' Syntax ........:
' Return values .: Success - void
' Author ........: Patrick
' Modified.......: 30/01/2018
' Remarks .......:
' Related .......:
' Link ..........: voir "_Verrouiller(label As String)"
' Example .......:
Private Sub _Liberer(Optional Label As String)
On error goto Erreur
SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)")
SgtDebug.Trace(Name, "*** VERROU INTERNE LIBERE ***", TRACE_EVENT)
_oDictFlags.Actualiser("FlagMutex", false)
Exit_Sub:
On error resume next
Exit Sub
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name, "_Liberer()")
Resume Exit_Sub
End Sub
' #PROCEDURE# ==================================================================
' Name...........: Trace
' Portée.........: PUBLIQUE
' Description ...: Trace l'état interne du Mutex dans le flux utilisé par l'objet
' TDebug en paramètre.
' Parameters ....: oDebug : TDebug : Un objet Debug
' Syntax ........:
' Return values .: Success - void
' Author ........: Patrick
' Modified.......: 30/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Sub Trace(oDebug As Object)
On error goto Erreur
_oDictFlags.Trace(oDebug)
Exit_Sub:
On error resume next
Exit Sub
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name, "_Trace()")
Resume Exit_Sub
End Sub
Rem ===========================================================================
Rem METHODES PUBLIQUES
Rem ===========================================================================
' #PROCEDURE# ==================================================================
' Name...........: VerrouillerFlag
' Portée.........: PUBLIQUE
' Description ...: Pose d'un verrou pour éviter un appel réentrant sur la méthode
' appelante.
' Parameters ....: sFlag : String : Le nom du verrou
' Syntax ........:
' Return values .: Success - void
' Author ........: Patrick
' Modified.......: 30/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Function VerrouillerFlag(sFlag As String, Optional sAppelant As String="") As Boolean
Dim ChienDeGarde As Integer
On local error goto Erreur
SgtDebug.Trace(Name, "*** DEMANDE BLOQUANTE DU VERROU EXTERNE " & sFlag & " par " & sAppelant & " ... ***", TRACE_EVENT)
_Verrouiller("FlagMutex")
'Si le flag du verrou n'existe pas alors il est ajouté à la
'collection courrante directement en mode réservation.
SgtDebug.Trace(Name, "Mutex contient " & sFlag & " ? : " & _oDictFlags.Contient(sFlag), TRACE_FLAG)
If not _oDictFlags.Contient(sFlag) Then
SgtDebug.Trace(Name, "CREATION DU VERROU " & sFlag, TRACE_EVENT)
_oDictFlags.Ajouter(sFlag, false)
Goto Exit_Function
EndIf
'Attente de la libération du verrou pour une durée max de _ChienMax * _Step millisecondes ...
ChienDeGarde = 1
While _oDictFlags.Item(sFlag) AND (ChienDeGarde <= _ChienMax)
SgtDebug.Trace(Name, " ... ", TRACE_EVENT)
wait(_Step)
ChienDeGarde = ChienDeGarde + 1
Wend
'Activation du verrou externe si ChienDeGarde < _ChienMax (flag = True)
If (ChienDeGarde <= _ChienMax) Then
_oDictFlags.Actualiser(sFlag, true)
SgtDebug.Assert(Name, not EstFlagLibre(sFlag), 12, TRACE_FLAG)
SgtDebug.Trace(Name, "*** VERROU " & sFlag & " ACTIVE POUR " & sAppelant & "(" & ChienDeGarde * _Step & " ms) ***", TRACE_EVENT)
Else
'On abandonne en laissant le verrou externe bloqué, mais on libère le verrour interne ...
'_oDictFlags.Actualiser(sFlag, false)
SgtDebug.Trace(Name, "*** VERROU " & sFlag & " ANNULE ET LIBERE. APPELANT ETAIT " & sAppelant & "(" & ChienDeGarde * _Step & " ms) ***", TRACE_EVENT)
Goto Exit_Function
EndIf
Exit_Function:
On error resume next
'Libération du verrou interne !
_Liberer("FlagMutex")
VerrouillerFlag = (ChienDeGarde <= _ChienMax)
Exit Function
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name, "ERREUR VerrouillerFlag()")
Resume Exit_Function
End Function
' #PROCEDURE# ==================================================================
' Name...........: LibererFlag
' Description ...: Libère le verrou nommé en paramètre.
' Parameters ....: sFlag : String : Le nom du verrou
' Syntax ........:
' Return values .: Success - void
' Author ........: Patrick
' Modified.......: 30/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Sub LibererFlag(sFlag As String, Optional sAppelant As String="")
On local error goto Erreur
SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)")
If not _oDictFlags.Contient(sFlag) Then
Goto Exit_sub
EndIf
_oDictFlags.Actualiser(sFlag, false)
SgtDebug.Trace(Name, "*** VERROU " & sFlag & " LIBERE. APPELANT ETAIT " & sAppelant & " ***", TRACE_EVENT)
Exit_Sub:
On error resume next
Exit Sub
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name, "LibererFlag()")
Resume Exit_Sub
End Sub
' #PROCEDURE# ==================================================================
' Name...........: EstFlagLibre
' Description ...: Vrai si le verrou nommé par le Flag est actif, sinon false
' Parameters ....: sFlag : String : Le nom du verrou
' Syntax ........:
' Return values .: Success - void
' Author ........: Patrick
' Modified.......: 30/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Function EstFlagLibre(sFlag As String) As Boolean
On local error goto Erreur
SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)")
SgtDebug.Trace(Name, "EstFlagLibre(" & sFlag & ") ? : Exist : " & _oDictFlags.Contient(sFlag) & ", EstVerrouille : " & _oDictFlags.Item(sFlag), TRACE_FLAG)
EstFlagLibre = _oDictFlags.Contient(sFlag) AND (not _oDictFlags.Item(sFlag))
Exit_Function:
On error resume next
Exit Function
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name, "Flag()")
Resume Exit_Function
End Function
Sub Main
Dim Mutex As Object
Mutex = getGlobalMutex()
Mutex.acquire()
Mutex.Release()
Erase Mutex
End Sub
Code : Tout sélectionner
REM ***** BASIC *****
Option Compatible
Option ClassModule
Option Base 0 ' Important pour le bon foncitonnement des fonctions FMT_***
Option Explicit
Rem Classe TDictionnaire : Tient à jour une liste triée d'étiquette, chacune
Rem reliée à un objet variant.
Rem Si la clé recherchée n'existe pas alors un exception est déclenchée. De même
Rem pour l'ajout si la clé existe déjà.
Rem ***************************************************************************
Rem
Rem TYPES / CONSTANTES / VARIABLES PRIVEES ET GLOBALES
Rem
Rem ***************************************************************************
Private _VecteurDict As Object 'Un vecteur d'objets TDuolet : (key, item)
Private const avant = -1
Private const apres = 1
Private const identique = 0
Private const _StepSize = 30
Rem ***************************************************************************
Rem
Rem CONSTRUCTORS / DESCTRUCTORS
Rem
Rem ***************************************************************************
Private Sub Class_Initialize()
_VecteurDict = new TVecteur
_VecteurDict.StepSize = _StepSize
End Sub
Private Sub Class_Terminate()
Vider()
Erase _VecteurDict
End Sub
Rem ***************************************************************************
Rem
Rem PROPRIETES
Rem
Rem ***************************************************************************
Public Property Let Titre(ByVal unTitre As String)
_VecteurDict.Titre = unTitre
End Property
Public Property Get Titre As String
Titre = _VecteurDict.Titre
End Property
Public Property Get AllItems As Variant
AllItems = _VecteurDict.AllItems
End Property
Public Property Get Vecteur As Object
Vecteur = _VecteurDict
End Property
Public Property Get Taille As Long
Taille = _VecteurDict.Taille
End Property
Public Property Get NBElements As Long
NBElements = _VecteurDict.NBElements
End Property
Public Property Let StepSize(ByVal delta As Long)
_VecteurDict.StepSize = delta
End Property
Public Property Get StepSize As Long
StepSize = _VecteurDict.StepSize
End Property
Public Property Get Iterateur As Object
Dim _Iterateur As Object
Set _Iterateur = New TIterateurVecteur
_Iterateur.InitialisePremier(_VecteurDict)
Iterateur = _Iterateur
End Property
Public Property Get Premier As Variant
Dim v As variant 'Nothing par defaut
If (NBElements > 0) Then
v = _VecteurDict.getItem(_VecteurDict.IdxMin).Item
EndIf
Premier = v
End Property
Public Property Get Dernier As Variant
Dim v As variant 'Nothing par defaut
If (NBElements > 0) Then
v = _VecteurDict.getItem(_VecteurDict.IdxMax).Item
EndIf
Premier = v
End Property
Rem ***************************************************************************
Rem
Rem METHODES PRIVEES
Rem
Rem ***************************************************************************
' #FUNCTION# ==================================================================
' Name...........: _TextComp
' Description ...:
' Parameters ....:
' Syntax ........: _TextComp(S1,S2,0)
' Return values .: N/A
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Private Function _TextComp(s1 As String, s2 As String, Optional bAvecCasse As Integer) As Integer
if IsMissing(bAvecCasse) Then bAvecCasse = 0
_TextComp = StrComp(s1, s2, bAvecCasse)
End Function
' #FUNCTION# ==================================================================
' Name...........: _FMT_ArrayHasKey
' Description ...: Determine if an array contains a specific string.Although a
'binary search is faster for large arrays, I expect small
'arrays here, so a linear search might be faster.
' Parameters ....:
' Syntax ........: _FMT_ArrayHasKey(skey)
' Return values .: Boolean
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Private Function _FMT_ArrayHasKey(skey As String) As Boolean
Dim i As Integer
Dim iUB As Integer
Dim iLB As Integer
On local Error Goto Erreur
_FMT_ArrayHasKey() = False
if _VecteurDict.EstVide Then Exit Function
iUB = _VecteurDict.IdxMax
iLB = _VecteurDict.IdxMin
Do
i = (iUB + iLB) \ 2
If _TextComp(_VecteurDict.getItem(i).key, skey) = identique Then
_FMT_ArrayHasKey() = True
'iLB = iUB + 1
Exit Function
ElseIf _TextComp(_VecteurDict.getItem(i).key, skey) = apres Then
iUB = i - 1
Else
iLB = i + 1
End If
Loop While iUB >= iLB
Exit_Function:
On error resume next
Exit Function
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name)
Resume Exit_Function
End Function
' #FUNCTION# ==================================================================
' Name...........: _FMT_IndexOfKey
' Description ...: L'index de la clé dans le vecteur trié.
' Parameters ....:
' Syntax ........: _FMT_IndexOfKey(skey)
' Return values .: Long :
' Success :
' Error : -1 si la clé n'est pas trouvée
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......: Voir aussi _FMT_IndexInArray qui calcul l'index qu'une clé
'devrait avoir pour trouver sa place dans le vecteur.
' Related .......:
' Link ..........:
' Example .......:
Private Function _FMT_IndexOfKey(skey As String) As Long
Dim i As Integer
Dim iUB As Integer
Dim iLB As Integer
On local Error Goto Erreur
_FMT_IndexOfKey = -1
if _VecteurDict.EstVide Then Exit Function
iUB = _VecteurDict.IdxMax
iLB = _VecteurDict.IdxMin
Do
i = (iUB + iLB) \ 2
If _TextComp(_VecteurDict.getItem(i).key, skey) = identique Then
_FMT_IndexOfKey() = i
'iLB = iUB + 1
Exit Function
ElseIf _TextComp(_VecteurDict.getItem(i).key, skey) = apres Then
iUB = i - 1
Else
iLB = i + 1
End If
Loop While iUB >= iLB
Exit_Function:
On error resume next
Exit Function
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name)
Resume Exit_Function
End Function
' #FUNCTION# ==================================================================
' Name...........: _FMT_GetItem
' Description ...:
' Parameters ....:
' Syntax ........: _FMT_GetItem(skey)
' Return values .: Variant
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Private Function _FMT_GetItem(sKey As String) As Variant
Dim i As Integer
Dim iUB As Integer
Dim iLB As Integer
On local Error goto Erreur
if _VecteurDict.EstVide Then Exit Function
iUB = _VecteurDict.IdxMax
iLB = _VecteurDict.IdxMin
Do
i = (iUB + iLB) \ 2
If _TextComp(_VecteurDict.getItem(i).key, sKey) = identique Then
_FMT_GetItem = _VecteurDict.getItem(i).Item
'iLB = iUB + 1
Exit Function
ElseIf _TextComp(_VecteurDict.getItem(i).key, sKey) = apres Then
iUB = i - 1
Else
iLB = i + 1
End If
Loop While iUB >= iLB
If (iUB < ILB) Then
Err = 960 'Clé introuvable
EndIf
Exit_Function:
On error resume next
Exit Function
Erreur:
TraceError("ERROR", Err, Name, Erl)
Stop
Resume Exit_Function
End Function
' #FUNCTION# ==================================================================
' Name...........: _FMT_InsertSortedArray
' Description ...: Insert a string in an array in formatted order.n% is the number
'of items in the array. The array is assumed to have room for
'one more item. Return True if s$ is inserted into the array,
'and False if the item is not inserted into the array. If it
'is not inserted,this means that it was already there
'(so it avoids duplicates).
' Parameters ....:
' Syntax ........: _FMT_InsertSortedArray(v, skey)
' Return values .: Boolean
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Private Function _FMT_InsertSortedArray(ByVal v As Variant, ByVal sKey As String) As Boolean
Dim duo As Object
Dim idx As Long
On local Error Goto Erreur
_FMT_InsertSortedArray = false
If Len(skey) = 0 Then exit Function
duo = New TDuolet
duo.key = skey
duo.item = v
'recherche de l'index que devrait avoir le nouvel élement après son insertion
idx = _FMT_IndexInArray(sKey)
'Cas 1 : Ajout en fin de vecteur
If (idx >= _VecteurDict.NBElements) Then
_VecteurDict.Ajouter(duo)
_FMT_InsertSortedArray = True
Exit Function
End If
'Cas 2 : Nouvel élément doublon, il n'est pas inséré.
If _TextComp(_VecteurDict.getItem(idx).key, sKey) = identique Then
_FMT_InsertSortedArray = False
Exit Function
End If
'Cas 3 : Insertion du nouvel élement à l'indice i
_VecteurDict.Inserer(idx, duo)
_FMT_InsertSortedArray = True
Exit_Function:
On error resume next
Exit Function
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name)
Resume Exit_Function
End Function
' #FUNCTION# ==================================================================
' Name...........: _FMT_IndexInArray
' Description ...: Find a string in an array. n% is the number of items in the array.
'Return the index where the string should be.
' Parameters ....:
' Syntax ........: _FMT_IndexInArray(skey)
' Return values .: Integer
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Private Function _FMT_IndexInArray(sKey) As Integer
Dim i As Integer
Dim iUB As Integer
Dim iLB As Integer
On local Error Goto Erreur
_FMT_IndexInArray() = _VecteurDict.Taille
If _VecteurDict.EstVide Then Exit Function
iUB = _VecteurDict.IdxMax
iLB = _VecteurDict.IdxMin
Do
i = (iUB + iLB) \ 2
If _TextComp(_VecteurDict.getItem(i).key, sKey) = identique Then
_FMT_IndexInArray() = i
Exit Function
'iLB = iUB + 1
ElseIf _TextComp(_VecteurDict.getItem(i).key, sKey) = apres Then
iUB = i - 1
Else
iLB = i + 1
End If
Loop While iUB >= iLB
_FMT_IndexInArray() = iLB
Exit_Function:
On error resume next
Exit Function
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name)
Resume Exit_Function
End Function
Rem ***************************************************************************
Rem
Rem METHODES PUBLIQUES
Rem
Rem ***************************************************************************
' #FUNCTION# ==================================================================
' Name...........: RangDe
' Description ...:
' Parameters ....:
' Syntax ........: RangDe(skey)
' Return values .: Long
' -1 si la clé n'est pas trouvée.
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
'Resultat = -1 si l'objet n'est pas trouvé
Public Function RangDe(key As String) As Long
RangDe = _FMT_IndexOfKey(key)
End Function
' #FUNCTION# ==================================================================
' Name...........: Actualiser
' Description ...:
' Parameters ....:
' Syntax ........: Actualiser(skey, false)
' Return values .: Actualise la valeur d'une clé. Si la clé n'est pas trouvée,
'la valeur n'est simplement pas actualisée.
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Sub Actualiser(key As String, value As Variant)
Dim Idx As Long
Dim duo As variant
On local Error Goto Erreur
Idx = RangDe(key)
If Idx >= 0 Then
duo = _VecteurDict.getItem(Idx)
duo.item = value
EndIf
Exit_Sub:
On error resume next
Exit SUb
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name)
Resume Exit_Sub
End Sub
' #FUNCTION# ==================================================================
' Name...........: Contient
' Description ...:
' Parameters ....:
' Syntax ........: Contient
' Return values .: Boolean
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Function Contient(skey As String) As Boolean
On error goto Erreur
Contient = _FMT_ArrayHasKey(skey) '_FMT_ArrayHasKey(key)
Exit_Function:
On error resume next
Exit Function
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name)
Resume Exit_Function
End Function
' #FUNCTION# ==================================================================
' Name...........: Item
' Description ...: Recherche un item selon sa clé. Si l'item n'existe pas une
' exception est déclenchée et traitée par _FMT_GetItem(key)
' Parameters ....:
' Syntax ........: Item(key)
' Return values .: Variant
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Function Item(key As String) As Variant
Item = _FMT_GetItem(key)
End Function
' #PROCEDURE# ==================================================================
' Name...........: Ajouter
' Description ...:
' Parameters ....:
' Syntax ........: Ajouter(key, item)
' Return values .:
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Sub Ajouter(key As String, ByVal item As Variant)
On error goto Erreur
If EstVide(key) Then
Err = 12
EndIf
If not _FMT_InsertSortedArray(item, key) Then
'L'Etiquette est déjà définie
Err = 959
EndIf
Exit_Sub:
On error resume next
Exit SUb
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name)
Resume Exit_Sub
End Sub
' #PROCEDURE# ==================================================================
' Name...........: Retirer
' Description ...:
' Parameters ....:
' Syntax ........: Retirer(skey)
' Return values .:
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Sub Retirer(skey As String)
Dim idx As Long
Dim duo As Object
On local error goto Erreur
idx = _FMT_IndexOfKey(skey)
if idx = -1 Then Exit Sub
duo = _VecteurDict.getItem(idx)
_VecteurDict.Retirer(idx)
Erase duo
Exit_Sub:
On error resume next
Exit Sub
Erreur:
TraceError("ERROR", Err, Name, Erl)
SgtDebug.Catch(Name)
Resume Exit_Sub
End Sub
' #PROCEDURE# ==================================================================
' Name...........: Trace
' Description ...:
' Parameters ....:
' Syntax ........: Trace(oDebug, Visiteur)
' Return values .:
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Function Trace(oDebug As Object)
_VecteurDict.Trace(oDebug)
End Function
' #PROCEDURE# ==================================================================
' Name...........: Vider
' Description ...:
' Parameters ....:
' Syntax ........: Vider()
' Return values .:
' Author ........: Patrick
' Modified.......: 01/02/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Sub Vider()
Dim i As Long
'Chaque entrée (item) du dictionnaire est un objet TDuolet créé par la
'méthode AJouter du dicitonnaire. Il revient donc au diictionnaire de les
'supprimer.
For i = _VecteurDict.IdxMax to _VecteurDict.IdxMin Step -1
Erase _VecteurDict.getItem(i)
Next
_VecteurDict.Vider()
End Sub
' #FUNCTION# ==================================================================
' Name...........: Main
' Description ...:
' Parameters ....:
' Syntax ........: Main
' Return values .:
' Author ........: Patrick
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Sub Main()
Dim oDict1, oDict2 As TDictionnaire
On local error goto Erreur
oDict1 = New TDictionnaire
oDict2 = New TDictionnaire
MsgBox oDict1.Contient("oDict2.3")
oDict1.Titre = "oDict1"
oDict2.Titre = "oDict2"
oDict1.Ajouter("oDict1.1", 1)
oDict1.Ajouter("oDict1.4", 4)
oDict1.Ajouter("oDict1.2", 2)
oDict1.Ajouter("oDict1.3", 3)
oDict2.Ajouter("oDict2.1", 1)
oDict2.Ajouter("oDict2.2", 4)
oDict2.Ajouter("oDict2.3", 2)
oDict2.Ajouter("oDict2.4", 3)
MsgBox oDict1.RangDe("oDict1.4")
MsgBox oDict1.Contient(4034)
Dim v1, v2 As boolean
v1 = oDict1.Item("toto")
MsgBox oDict2.Item("oDict2.4")
MsgBox oDict2.Contient("oDict2.3")
oDict2.Retirer("oDict2.3")
MsgBox oDict2.Contient("oDict2.3")
MsgBox oDict2.Premier
MsgBox oDict2.Dernier
Erase oDict1
Erase oDict2
Exit_Sub:
On error resume next
Exit Sub
Erreur:
TraceError("ERROR", Err, Name, Erl)
Resume Exit_Sub
End Sub