[Class] cStack (VB6)

Aquí te dejo mi clase Stack la acabe de hacer con el block de notas... espero funcione ya que no tengo el IDE de VB6.

(Prueben el código seguro hay varios errores ya que no la probe)

Stack.cls

Código

 
option explicit
 
private _stack   as long
private _size   as long
private _element as variant
 
Private Sub Class_Initialize()
    _stack = &H0
    _size = &H0
End Sub
 
Private Sub Class_Terminate()
    while (empty() = false)
        pop()
    loop
End Sub
 
Public property get size() as long
    size = _size
End Sub
 
Public function top() as variant
    if isobject(_element) then
        set top = _element
    else
        top = _element
    end if
End property
 
pyblic function empty() as boolean
    empty = (_size = 0)
end function
 
Public Sub push(Byref variable As variant)
dim ptr   as long
dim ptrw  as long
    ptr = mMemoryEx.malloc(8)
    ptrw = mMemoryex.getMemData(ptr)
    mMemoryEx.putdword(ptrw, _stack)
 
    if isobject(variable) then
        set _element(0) = variable
    else
        _element(0) = variable
    end if
 
    mMemoryEx.putdword((ptrw + 4), mMemoryEx.getdword(varptr(_element(0))))
    _stack = ptrw
    _size = (_size + 1)
End Sub
 
Public sub pop()
dim newset as variant
dim ptrl   as long
dim ptrw   as long
 
    if _size = 0 then exit sub
 
    ptrl = _stack
    ptrw = mMemoryex.getMemData(ptrl)
    mMemoryEx.putdword(varptr(_stack), mMemoryEx.getdword(ptrw))
    mMemoryEx.putdword(varptr(newset), mMemoryEx.getdword(ptrw + 4))
    mMemoryex.releaseMem(ptrl)
 
   _size = (_size - 1)
End sub

Como esta caída mi pagina (Blog) dejo el modulo:

mMemoryEx.bas

Código:


Option Explicit

Public Const PAGE_EXECUTE_READWRITE As Long = &H40
Public Const PAGE_EXECUTE_WRITECOPY As Long = &H80
Public Const PAGE_EXECUTE_READ As Long = &H20
Public Const PAGE_EXECUTE As Long = &H10
Public Const PAGE_READONLY As Long = 2
Public Const PAGE_WRITECOPY As Long = &H8
Public Const PAGE_NOACCESS As Long = 1
Public Const PAGE_READWRITE As Long = &H4
 
Declare Function VarPtrArr Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Declare Function IsBadWritePtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long
Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long
Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByVal lpflOldProtect As Long) As Long

Private bvHack(0)               As Byte
Private lHackDelta              As Long
Private bInitialized            As Boolean
 
Public Function initialize() As Boolean ' By KarCrack
    On Error GoTo Error_Handle
 
    bvHack(-1) = bvHack(-1) 'Error check
    lHackDelta = VarPtr(bvHack(0))
 
    initialize = True
    bInitialized = initialize
    Exit Function
Error_Handle:
    If Err.Number = 9 Then Debug.Print "Remember to tick 'Remove array boundary check' and compile before using"
'    End
End Function
 
Public Function getByte(ByVal lptr As Long) As Byte ' By KarCrack
    If bInitialized Then getByte = bvHack(lptr - lHackDelta)
End Function
 
Public Function getWord(ByVal lptr As Long) As Integer ' By KarCrack
    If bInitialized Then getWord = makeWord(getByte(lptr + &H0), getByte(lptr + &H1))
End Function
 
Public Function getDWord(ByVal lptr As Long) As Long ' By KarCrack
    If bInitialized Then getDWord = makeDWord(getWord(lptr + &H0), getWord(lptr + &H2))
End Function
 
Public Sub putByte(ByVal lptr As Long, ByVal bByte As Byte) ' By KarCrack
    If bInitialized Then bvHack(lptr - lHackDelta) = bByte
End Sub
 
Public Sub putWord(ByVal lptr As Long, ByVal iWord As Integer) ' By KarCrack
    If bInitialized Then Call putByte(lptr + &H0, iWord And &HFF): Call putByte(lptr + &H1, (iWord And &HFF00&) / &H100)
End Sub
 
Public Sub putDWord(ByVal lptr As Long, ByVal lDWord As Long) ' By KarCrack
    If bInitialized Then Call putWord(lptr + &H0, IIf(lDWord And &H8000&, lDWord Or &HFFFF0000, lDWord And &HFFFF&)): Call putWord(lptr + &H2, (lDWord And &HFFFF0000) / &H10000)
End Sub
 
Public Function makeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long '[http://www.xbeat.net/vbspeed/c_MakeDWord.htm#MakeDWord05]
    makeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function

'   //  Funciones agregadas...

Function makeWord(ByVal lByte As Byte, ByVal hByte As Byte) As Integer ' By BlackZeroX
    makeWord = (((hByte And &H7F) * &H100&) Or lByte)
    If hByte And &H80 Then makeWord = makeWord Or &H8000
End Function

'/////////////////////
Public Function allocMem(ByVal lSize As Long) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  Retorna la Dirrecion de un SafeArray.
Dim pBuff()     As Byte
    If (lSize <= &H0) Then Exit Function
    ReDim pBuff(0 To (lSize - 1))
    allocMem = getDWord(VarPtrArr(pBuff))
    putDWord VarPtrArr(pBuff), 0
End Function
 
Public Function reallocMem(ByVal lptr As Long, ByVal lSize As Long) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  Retorna la Dirrecion de un SafeArray que se retorno en allocMem()/reallocMem().
Dim pBuff()     As Byte
    putDWord VarPtrArr(pBuff), lptr
    If Not (lSize = &H0) Then
        ReDim Preserve pBuff(0 To (lSize - 1))
    Else
        Erase pBuff
    End If
    reallocMem = getDWord(VarPtrArr(pBuff))
    putDWord VarPtrArr(pBuff), 0
End Function
 
Public Function getMemData(ByVal lptr As Long) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  lPtr debe ser el valor (Address) que retorno en allocMem()/reallocMem().
'   //  Esta funcion retorna la Dirrecion de memoria EDITABLE de lPtr (Dirrecion de un SafeArray).
'   //  Referencias.
'   //  http://msdn.microsoft.com/en-us/library/aa908603.aspx
    If (lptr = &H0) Then Exit Function
    getMemData = getDWord(lptr + &HC)    '   //  obtenemos pvData
End Function
 
Public Sub releaseMem(ByVal lptr As Long)
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  lPtr debe ser la Dirrecion que retorno en allocMem()/reallocMem().
Dim pBuff()     As Byte
    putDWord VarPtrArr(pBuff), lptr
End Sub
 
Public Sub releaseMemStr(ByVal lptr As Long)
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  lPtr debe ser la Dirrecion que retorno en cloneString().
Dim sStr        As String
    putDWord VarPtr(sStr), lptr
End Sub
 
Public Sub swapVarPtr(ByVal lpVar1 As Long, ByVal lpVar2 As Long)
'   //  By BlackZeroX (Thanks to Karcrack).
Dim lAux    As Long
    lAux = getDWord(lpVar1)
    Call putDWord(lpVar1, getDWord(lpVar2))
    Call putDWord(lpVar2, lAux)
End Sub
 
Public Function cloneString(ByVal lpStrDst As Long, ByVal sStrSrc As String) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
'   //  lPtr -> Puntero a una variable destino (Preferiblemente String).
'   //  sStr -> Cadena Clonada ( gracias a Byval ).
Dim lpStrSrc        As Long
    If Not (lpStrDst = &H0) And (mMemoryEx.initialize = True) Then
        Call mMemoryEx.swapVarPtr(lpStrDst, VarPtr(sStrSrc))
        Call mMemoryEx.swapVarPtr(VarPtr(cloneString), VarPtr(sStrSrc))
    End If
End Function
 
Public Function copyMemory(ByVal lpDst As Long, ByVal lpSrc As Long, ByVal lLn As Long) As Long
'   //  By BlackZeroX (Thanks to Karcrack).
Dim i       As Long
    If (lpSrc = &H0) Or (lpDst = &H0) Or (lLn = &H0) Then Exit Function
   
    i = (lLn Mod 4)
    If ((i And &H2) = &H2) Then
        Call putWord(lpDst, getWord(lpSrc))
        lpDst = (lpDst + 2)
        lpSrc = (lpSrc + 2)
        copyMemory = (copyMemory + 2)
        lLn = (lLn - 2)
    End If
    If ((i And &H1) = &H1) Then
        Call putByte(lpDst, getByte(lpSrc))
        lpDst = (lpDst + 1)
        lpSrc = (lpSrc + 1)
        copyMemory = (copyMemory + 1)
        lLn = (lLn - 1)
    End If
    For i = 0 To (lLn - 1) Step 4
        Call putDWord(lpDst + i, getDWord(lpSrc + i))
    Next
    copyMemory = (copyMemory + lLn)
   
End Function

Dulces Lunas!¡.