Estoy un poco aburrido y me e puesto a hacer esto:
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
'
' /////////////////////////////////////////////////////////////
' // 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
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!¡.