'---------------------------------------------------------------------------------------
' Module : mMemory
' Author : Karcrack
' Date : 20/09/2011
' Purpose : Work with memory withouth using any API
' History : 20/09/2011 First cut .....................................................
'---------------------------------------------------------------------------------------
Option Explicit
Public Declare Function VarPtrArr Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Private bvHack(0) As Byte
Private lHackDelta As Long
Private bInitialized As Boolean
Public Function Initialize() As Boolean
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
If bInitialized Then GetByte = bvHack(lptr - lHackDelta)
End Function
Public Function GetWord(ByVal lptr As Long) As Integer
If bInitialized Then GetWord = MakeWord(GetByte(lptr + &H0), GetByte(lptr + &H1))
End Function
Public Function GetDWord(ByVal lptr As Long) As Long
If bInitialized Then GetDWord = MakeDWord(GetWord(lptr + &H0), GetWord(lptr + &H2))
End Function
Public Sub PutByte(ByVal lptr As Long, ByVal bByte As Byte)
If bInitialized Then bvHack(lptr - lHackDelta) = bByte
End Sub
Public Sub PutWord(ByVal lptr As Long, ByVal iWord As Integer)
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)
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 MakeWord(ByVal loByte As Byte, ByVal hiByte As Byte) As Integer '[http://www.xbeat.net/vbspeed/c_MakeWord.htm#MakeWord02]
If hiByte And &H80 Then
MakeWord = ((hiByte * &H100&) Or loByte) Or &HFFFF0000
Else
MakeWord = (hiByte * &H100) Or loByte
End If
End Function
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
'/////////////////////
Public Function allocMem(ByVal lSize As Long) As Long
' // By BlackZeroX (Thanks to Karcrack to GetDWord() function and PutDWord() function ).
' // 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 to GetDWord() function and PutDWord() function ).
' // 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 to GetDWord() function and PutDWord() function ).
' // 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 to GetDWord() function and PutDWord() function ).
' // 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 to GetDWord() function and PutDWord() function ).
' // 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 to GetDWord() function and PutDWord() function ).
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 to GetDWord() function and PutDWord() function ).
' // lPtr -> Puntero a una variable destino (Preferiblemente String).
' // sStr -> Cadena Clonada ( gracias a Byval ).
Dim lpStrSrc As Long
If Not (lpStrDst = &H0) And (mMemory.Initialize = True) Then
Call mMemory.swapVarPtr(lpStrDst, VarPtr(sStrSrc))
Call mMemory.swapVarPtr(VarPtr(cloneString), VarPtr(sStrSrc))
End If
End Function
Public Function writeMemory(ByVal lpDataDst As Long, ByVal lpDataSrc As Long, ByVal lLn As Long) As Long
' // By BlackZeroX (Thanks to Karcrack to GetDWord() function and PutDWord() function ).
Dim i As Long
If (lpDataSrc = &H0) Or (lpDataDst = &H0) Or (lLn = &H0) Then Exit Function
i = (lLn Mod 4)
If ((i And &H2) = &H2) Then
Call PutWord(lpDataDst, GetWord(lpDataSrc))
lpDataDst = (lpDataDst + 2)
lpDataSrc = (lpDataSrc + 2)
writeMemory = (writeMemory + 2)
lLn = (lLn - 2)
End If
If ((i And &H1) = &H1) Then
Call PutByte(lpDataDst, GetByte(lpDataSrc))
lpDataDst = (lpDataDst + 1)
lpDataSrc = (lpDataSrc + 1)
writeMemory = (writeMemory + 1)
lLn = (lLn - 1)
End If
For i = 0 To (lLn - 1) Step 4
Call PutDWord(lpDataDst + i, GetDWord(lpDataSrc + i))
Next
writeMemory = (writeMemory + lLn)
End Function
Autor
En línea
Lo corrijo 
Could you give us a sample please?
