Foro de elhacker.net

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!¡.