XL 2013 comment lire les éléments d'une collection dans une boucle

[patricktoulon]

Bonjour a tous
je me sert d'une collection pour memoriser une valeur et sa clé
pour lire un element je l'appelle par sa clé
mais dans une boucle incrémentée comment fait on pour chopper la valeur et la clé ?

Dim matos As New Collection

Sub test()
   'matos.Add  valeur, clé
    matos.Add "bleue", "voiture"
    matos.Add "rouge", "velo"
    matos.Add "verte", "trotinnette"

    MsgBox matos("velo")

    For i = 1 To matos.Count
        'ici debug.print la valeur et la clé
    Next

End Sub

 

[patricktoulon]

allez je reviens la dessus pour cloturer
j'ai trouvé en effet Arkham46 sur DVP avait trouvé une solution avec l'api rtlmemory
dans un module

Option Explicit
 
' API pour déplacement de zone mémoire
Private Declare Sub RtlMoveMemory Lib "kernel32" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
 
' --------------------------------------------------------------------
' Renvoit la clé d'un item d'indice pItem d'une collection pColl
' --------------------------------------------------------------------
Function CollGetKey(pColl As Collection, pItem As Long) As String
Dim lBuffer(1 To 8) As Long ' Buffer pour information sur la collection
Dim lItem(1 To 7) As Long ' Buffer pour information sur l'Item
Dim lKey() As Byte ' Buffer pour la clé de l'item
Dim lCpt As Long ' Compteur d'item
Dim lPtr As Long ' Pointeur
Dim lSize As Long ' Taille de la clé
On Error GoTo Gestion_Erreurs
' Test objet initialisé
If ObjPtr(pColl) <> 0 Then
    ' Lecture informations de la collection
    RtlMoveMemory lBuffer(1), ByVal ObjPtr(pColl), 8 * 4
    ' Lecture informations du premier item
    If lBuffer(7) <> 0 Then
        RtlMoveMemory lItem(1), ByVal lBuffer(7), 7 * 4
        ' Boucle pour lire les items
        Do
            lCpt = lCpt + 1
            ' Si l'indice de l'item correspond
            If lCpt = pItem Then
                ' Pointeur vers clé
                lPtr = lItem(5)
                ' Si une clé existe
                If lPtr <> 0 Then
                    ' Taille de la clé
                    RtlMoveMemory lSize, ByVal lPtr - 4, 4
                    ' Buffer de réception de la clé
                    ReDim lKey(1 To lSize)
                    ' Récupère la clé
                    RtlMoveMemory lKey(1), ByVal lPtr, lSize
                    ' Conversion unicode
                    CollGetKey = StrConv(lKey(), vbUnicode)
                    CollGetKey = StrConv(CollGetKey, vbFromUnicode)
                    Exit Do
                Else
                    ' Pas de clé
                    CollGetKey = ""
                    Exit Do
                End If
            Else ' Sinon, on passe à l'item suivant
                ' Pointeur vers item suivant
                lPtr = lItem(7)
                If lPtr <> 0 Then
                    ' Lecture informations de l'item
                    RtlMoveMemory lItem(1), ByVal lPtr, 7 * 4
                Else
                    ' On a parcouru tous les items => pas normal
                    CollGetKey = ""
                    Exit Do
                End If
            End If
        Loop
    Else
        CollGetKey = ""
    End If
Else
    CollGetKey = ""
End If
' Gestion des erreurs
On Error GoTo 0
Exit Function
Gestion_Erreurs:
    CollGetKey = ""
End Function

et dans un autre module je teste

Sub TestCollKey()
Dim Collect As New Collection, i As Long
Collect.Add "toto", "54"
Collect.Add "titi", "28"
Collect.Add "fifi", "32"

For i = 1 To Collect.Count
Debug.Print Collect(i) & " ," & CollGetKey(Collect, i)
Next
End Sub

celui là si il n'existait pas il faudrait l'inventer

 

[RyuAutodidacte]

Re,

' API pour déplacement de zone mémoire
Private Declare Sub RtlMoveMemory Lib "kernel32" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Code uniquement pour les PC

 

[patricktoulon]

re
a ben ça