Esta clase la he creado para tratar un poco las listas enlazadas de la manera:
Elemento 1, Elemento 2, ... , Elemento N
Es decir que la clase EMULA las listas enlazadas que libremente se pueden escribir con punteros en C/C++ pero en listas lineales.
* No estan enlazadas en forma de arbol.
De tal modo que Dejo de sustitucion a Redim Preserve NO en todos los casos Ojo.
Ventajas:
* Asigna memoria dependiendo sin cambiar la hubicacion de los demas elementos ( agregacion rapida de elementos ).
* Se trata a la memoria como un bloque de bytes como cualquier otro (Generico).
Desventajas:
* No se puede usar Copymemory para copiar a mas de 1 elemento...
* Solo es utilizable para casos contados...
cListLink.cls
Código
' ' ///////////////////////////////////////////////////////////// ' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) // ' // // ' // Web: http://InfrAngeluX.Sytes.Net/ // ' // // ' // |-> Pueden Distribuir Este codigo siempre y cuando // ' // no se eliminen los creditos originales de este codigo // ' // No importando que sea modificado/editado o engrandecido // ' // o achicado, si es en base a este codigo // ' ///////////////////////////////////////////////////////////// ' // // ' // * Esta es una lista de 1 solo Orden... es decir no es // ' // de ordenamiento en arbol... // ' // // ' ///////////////////////////////////////////////////////////// ' // http://infrangelux.hostei.com/index.php?option=com_content&view=article&id=29:clistlink&catid=15:catmoduloscls&Itemid=24 ' ///////////////////////////////////////////////////////////// Option Explicit Private Const MEM_DECOMMIT = &H4000 Private Const MEM_RELEASE = &H8000 Private Const MEM_COMMIT = &H1000 Private Const MEM_RESERVE = &H2000 Private Const MEM_RESET = &H80000 Private Const MEM_TOP_DOWN = &H100000 Private Const PAGE_READONLY = &H2 Private Const PAGE_READWRITE = &H4 Private Const PAGE_EXECUTE = &H10 Private Const PAGE_EXECUTE_READ = &H20 Private Const PAGE_EXECUTE_READWRITE = &H40 Private Const PAGE_GUARD = &H100 Private Const PAGE_NOACCESS = &H1 Private Const PAGE_NOCACHE = &H200 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal ByteLen As Long) Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long Private Declare Function VirtualLock Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long) As Long Private Declare Function VirtualUnlock Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long) As Long 'Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long 'Private Declare Function IsBadWritePtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long 'Private Declare Function IsBadStringPtr Lib "kernel32" Alias "IsBadStringPtrA" (ByVal lpsz As Long, ByVal ucchMax As Long) As Long 'Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpStringDest As String, ByVal lpStringSrc As Long) As Long 'Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (ByVal Destination As Long, ByVal Length As Long) Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long) Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal RetVal As Long) Dim pfirst As Long Dim pLast As Long Dim lSize As Long Const SIZEAB As Long = &H8 Const BEFORESIZE As Long = &H0 Const AFTERSIZE As Long = (BEFORESIZE + &H4) Public Function release(ByVal pStream As Long) As Boolean Dim lSizeF As Long Dim pAfter As Long Dim pBefore As Long If (pStream = &H0) Then Exit Function lSizeF = (SIZEAB + lSize) pAfter = after(pStream) pBefore = before(pStream) VirtualUnlock pStream, lSizeF VirtualFree pStream, lSizeF, MEM_DECOMMIT VirtualFree pStream, 0, MEM_RELEASE If (pAfter) Then putBefore pAfter, pBefore If (pBefore) Then putAfter pBefore, pAfter If (pStream = pfirst) Then pfirst = pBefore If (pStream = pLast) Then pLast = pAfter release = True End Function Public Function getPtr(ByVal lIndex As Long) As Long ' // Retorna el puntero del elemento indicado en lIndex. Dim pTmp As Long Dim i As Long pTmp = first() Do Until (pTmp = &H0) i = (i + &H1) If (i > lIndex) Then Exit Do pTmp = after(pTmp) Loop getPtr = pTmp End Function Public Property Get size() As Long size = lSize End Property Public Property Let size(ByVal lVal As Long) Call clear lSize = lVal End Property Friend Sub writeStream(ByVal pStruct As Long, ByVal pData As Long) ' // Setea los valores en el bloque de la memoria de la lista enlazada. CopyMemory pStruct, pData, lSize End Sub Friend Function readStream(ByVal pStruct As Long, ByVal pData As Long) ' // Retorna los valores del bloque de la lista enlazada a una bloque. CopyMemory pData, pStruct, lSize End Function ' // Estas funciones otienen el 1er y ultimo elemento agregado a la lista. Friend Function first() As Long first = pfirst End Function Friend Function last() As Long last = pLast End Function ' // funciones iteradoras. Friend Function after(ByVal pStruct As Long) As Long ' // Rectorna del puntero al bloque que se agrego despues de pStruct Dim pTmp As Long If (pStruct = &H0) Then Exit Function GetMem4 ByVal (pStruct + lSize + AFTERSIZE), VarPtr(pTmp) after = pTmp End Function Friend Function before(ByVal pStruct As Long) As Long ' // Rectorna del puntero al bloque anteriormente agregado de pStruct Dim pTmp As Long If (pStruct = &H0) Then Exit Function GetMem4 ByVal (pStruct + lSize + BEFORESIZE), VarPtr(pTmp) before = pTmp End Function Friend Function addNew() As Long ' // Agrega un nuevo bloque y lo enlaza. Dim lSizeF As Long Dim pNew As Long lSizeF = (SIZEAB + lSize) pNew = VirtualAlloc(ByVal 0&, lSizeF, MEM_COMMIT, PAGE_EXECUTE_READWRITE) VirtualLock pNew, lSizeF ZeroMemory pNew, lSizeF ' // llenamos de 0 el bloque. If (pLast) Then ' // Actualizamos el ultimo... putBefore pNew, pLast putAfter pLast, pNew End If If (pfirst = &H0) Then pfirst = pNew pLast = pNew addNew = pNew End Function Private Sub putAfter(ByVal pStruct As Long, ByVal pAfter As Long) If (pStruct = &H0) Then Exit Sub PutMem4 (pStruct + lSize + AFTERSIZE), pAfter ' // pNew.After End Sub Private Sub putBefore(ByVal pStruct As Long, ByVal pBefore As Long) If (pStruct = &H0) Then Exit Sub PutMem4 (pStruct + lSize + BEFORESIZE), pBefore ' // pNOW.BEFORE End Sub Public Function clear() As Long ' // Libera la memoria asignada y retorna la cantidad liberada en bytes. Dim lSizeRet As Long Dim pTmp As Long pTmp = first() ' // Seteamos el 1ro. Do Until (release(pTmp) = False) lSizeRet = (lSizeRet + lSize + SIZEAB) pTmp = first() Loop clear = lSizeRet End Function Private Sub Class_Terminate() Call clear End Sub
Ejemplo de uso
Código
Option Explicit Private Type DATOSPERSONALES edad As Long categoria As Long nombre As String * 20 apellidoP As String * 10 apellidoM As String * 10 End Type Private Sub Form_Load() Dim oList As cListLink Dim tDatosP As DATOSPERSONALES ' // Plantilla... Dim pElement As Long ' // Puntero al elemento... Set oList = New cListLink oList.size = LenB(tDatosP) ' // Tamaño de la estructura (bloque de datos). With tDatosP .edad = 22 .categoria = 1 .nombre = "Miguel Angel" .apellidoP = "Ortega" .apellidoM = "Avila" End With Call oList.writeStream(oList.addNew(), VarPtr(tDatosP)) ' // Escribimos la estructura en una lista enlazada. With tDatosP .edad = 42 .categoria = 2 .nombre = "Angel" .apellidoP = "Ortega" .apellidoM = "Hernandez" End With Call oList.writeStream(oList.addNew(), VarPtr(tDatosP)) ' // Escribimos la estructura en una lista enlazada. With tDatosP .edad = 19 .categoria = 2 .nombre = "Maria Luisa" .apellidoP = "Beltran" .apellidoM = "Ramirez" End With Call oList.writeStream(oList.addNew(), VarPtr(tDatosP)) ' // Escribimos la estructura en una lista enlazada. 'Call oList.release(oList.before(oList.firts())) ' // Liberamos el 2 registro ("Angel Ortega Hernandez"), para eso obtenemos el 1 elemento y obtenemos el siguiente elemento con before... Call oList.release(oList.getPtr(1)) ' // Eliminamos el elemento con Index 1 ' // Retornamos los elementos... pElement = oList.first() Do Until (pElement = &H0) oList.readStream pElement, VarPtr(tDatosP) With tDatosP Debug.Print "Nombre:", .nombre Debug.Print "ApellidoP:", .apellidoP Debug.Print "ApellidoM:", .apellidoM Debug.Print "Edad:", .edad Debug.Print "Categoria:", .categoria Debug.Print Debug.Print Debug.Print End With pElement = oList.after(pElement) Loop Set oList = Nothing End Sub
Temibles Lunas!¡.