1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
|
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 |
Partager