Mensajes

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 (vb) [Seleccionar] Expandir



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 [Seleccionar] Expandir



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

Revisa estas especificaciones.

http://www.iso.org/iso/catalogue_detail.htm?csnumber=29581
http://www.libpng.org/pub/png/spec/1.1/           <-- recomendada.

P.D.: Google no muerde.

Dulces Lunas!¡.

Si usa Internet no me funciona y a muchos tampoco, deberías meterle algunas ya por default y solo tener un botón extra para obtener las nuevas y actualizar tu BDD de seriales... así los que no tienen Internet activado tengan acceso aun que sea a algunos códigos "serial".

Muy bueno! As estudiado el algoritmo mediante Ing. Inversa o como lo as sacado?

No creo, al parecer las toma de una pagina, pero da igual que método sea lo que importa aquí realmente es que cumple su trabajo.

Nota: Crea un instalador o algo similar (Ya no uso VB6) y las personas que no tienen algunas librerias no les funciona tu App.

Dulces Lunas!¡.

Puedes usar mi alternativa que usa el mismo método de "Ignorar limites de un array".

Alternativa a CopyMemory

solo una modificacion:

Código (vb) [Seleccionar] Expandir



Public Function copyMemory(ByVal lpDst As Long, ByVal lpSrc As Long, ByVal lLn As Long) As Long
'   //  By BlackZeroX.
Dim i       As Long

    If not bInitialized Then exit function

    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



Pon el código tal cual los tipos de c y de b pueden afectar en tu resultado, ya que cada tipo ocupa una longitud dada de bytes.

Dulces Lunas!¡.

El usar solo elnombre de una array es decir asi como lo usas en el segundo indica un puntero al primer indice es decir  "&variable[0]" es igual a "variable"...

Dulces Lunas!¡.

Código (c) [Seleccionar] Expandir



...

switch(getchar()) {
    case 'a': ... break
    case 'b': ... break
    case 'c': ... break
    case 'd': ... break
    ...
    case '0': ... break
    case '1': ... break
    case '2': ... break;
    case '3': ... break;
    case '4': ... break;
    case '5': ... break;
    case '6': ... break;
    case '7': ... break;
    case '8': ... break;
    case '9': ... break;
    default: ... break;
}

...



Dulces Lunas!¡.

.
Uff de eso ya hace bastante tiempo, recuerdo que la cree cuando empezaba con Ajax y la traduje a vb6 después vi que era un molde bastante "básico" y rutinario (repetible) por decirlo de alguna manera, en su tiempo quedo aclarado el asuntito.

Llenándonos a algo mas de lleno a quien le agrade el diseño y codificación web lo sabra...

http://www.w3schools.com/ajax/default.asp

Dulces Lunas!¡.

Si estas usando C++ no te preocupes tienes len la STL el algoritmo de ordenamiento mira

http://www.cplusplus.com/reference/algorithm/sort/

Dulces Lunas!¡.

Alternativa a la función Xor...

Código (vb) [Seleccionar] Expandir



Option Explicit

Private Sub Form_Load()
Const a As Long = 0
Const b As Long = 1
    MsgBox Xor_alt(a, b) & vbCrLf & (a Xor b)
End Sub

Public Function Xor_alt(ByVal n1 As Long, ByVal n2 As Long) As Long
    Xor_alt = (Not n1) And n2 Or (Not n2) And n1
End Function




P.D.: Necesito crearle un Indice a este tema... cuando tenga tiempo libre lo haré...

Dulces Lunas!¡.