.
Quisas te interese mi codigo... (tiene un error que no he corregido, al rato lo corregire)
[Reto] Sudoku
Dulces Lunas!¡.
Quisas te interese mi codigo... (tiene un error que no he corregido, al rato lo corregire)
[Reto] Sudoku
Dulces Lunas!¡.
Esta sección te permite ver todos los mensajes escritos por este usuario. Ten en cuenta que sólo puedes ver los mensajes escritos en zonas a las que tienes acceso en este momento.
Mostrar Mensajes MenúCita de: Slek Hacker en 3 Noviembre 2011, 21:32 PM
Tengo un par de preguntas sobre este tema. A ver, la función reallocMem, ¿la usas para convertir los datos de Long a Integer (osea, de 8 bytes de tamaño a 4)?
Cita de: Slek Hacker en 3 Noviembre 2011, 21:32 PM
¿Para qué sirve exactamente releaseMem?
Cita de: Slek Hacker en 3 Noviembre 2011, 21:32 PM
¿Por qué sumas +3 a la dirección de memoria editable del SafeArray?
Cita de: Slek Hacker en 3 Noviembre 2011, 21:32 PM
Y la función reallocMem, ¿no debería ser así?
Cita de: Raul100 en 3 Noviembre 2011, 09:02 AM
hablemos en chino pues![]()
Option Explicit
Private Declare Function MessageBox Lib "VTFS43" Alias "NfttbhfCpyB" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Declare Function IsBadWritePtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long
Public Function unScrambleAPI(ByVal sLibName As String, ByVal sFuncName As String) As Boolean
Dim pBaseAddress As Long
Dim pVB5 As Long
Dim pProjectInfo As Long
Dim pExtTable As Long
Dim pLibraryName As Long
Dim pFunctionName As Long
Dim iExtCount As Long
Dim iIndex As Long
Dim bLibNameOri() As Byte
Dim bFuncNameOri() As Byte
'Do NOT run it on the IDE
If App.LogMode = 0 Then Debug.Assert (0 = 1): Exit Function
pBaseAddress = App.hInstance
pVB5 = getDWord(pBaseAddress + getDWord(pBaseAddress + getDWord(pBaseAddress + &H3C) + &H28) + 1)
pProjectInfo = getDWord(pVB5 + &H30)
pExtTable = getDWord(pProjectInfo + &H234)
iExtCount = getDWord(pProjectInfo + &H238)
bLibNameOri = StrConv(decrypt(sLibName), vbFromUnicode)
bFuncNameOri = StrConv(decrypt(sFuncName), vbFromUnicode)
For iIndex = 0 To iExtCount - 1
If getDWord(pExtTable) <> 6 Then
pLibraryName = getDWord(getDWord(pExtTable + &H4) + &H0)
pFunctionName = getDWord(getDWord(pExtTable + &H4) + &H4)
If (pLibraryName <> 0) And (pFunctionName <> 0) Then
If readString(pLibraryName) = sLibName Then
If readString(pFunctionName) = sFuncName Then
If Not (IsBadWritePtr(pLibraryName, (UBound(bLibNameOri) + 1)) = &H0) Then
MsgBox "require Unlock BlockMemory"
Else
Call writeByte(pLibraryName, bLibNameOri)
End If
If Not (IsBadWritePtr(pFunctionName, (UBound(bFuncNameOri) + 1)) = &H0) Then
MsgBox "require Unlock BlockMemory"
Else
Call writeByte(pFunctionName, bFuncNameOri)
End If
unScrambleAPI = True
End If
End If
End If
End If
pExtTable = pExtTable + 8
Next iIndex
End Function
Private Function readString(ByVal lptr As Long) As String
Dim i As Long
Dim b As Byte
Do
b = getByte(lptr + i)
If b = 0 Then Exit Do
readString = readString & Chr$(b)
i = i + 1
Loop
End Function
Public Function itsArrayIni(ByVal lptr As Long) As Boolean
itsArrayIni = Not (getDWord(lptr) = &H0)
End Function
Private Function writeByte(ByVal lptr As Long, ByRef bData() As Byte) As Long
If (Not itsArrayIni(VarPtrArr(bData))) Then Exit Function
writeByte = writeMemory(lptr, VarPtr(bData(0)), (UBound(bData) + 1))
End Function
Private Function decrypt(ByRef sStr As String) As String
Dim i As Long
decrypt = Space(Len(sStr))
For i = 1 To Len(sStr)
Mid$(decrypt, i, 1) = Chr$(Asc(Mid$(sStr, i, 1)) - 1)
Next i
End Function
Public Sub encrypt(ByRef sData As String)
Dim i As Long
For i = 1 To Len(sData)
Mid$(sData, i, 1) = Chr$(Asc(Mid$(sData, i, 1)) + 1)
Next i
End Sub
Sub Main()
Const LIBNAME As String = "VTFS43"
Const FUNCNAME As String = "NfttbhfCpyB"
If mMemory.initialize Then
If unScrambleAPI(LIBNAME, FUNCNAME) = True Then
Call MessageBox(0, ":)", ":)", 0)
End If
Else
MsgBox "Error"
End If
End Sub
Option Explicit
Private Sub Form_Load()
Dim sStr1 As String
Dim sStr2 As String
Dim lpStr As Long
sStr1 = "BlackZeroX"
sStr2 = "InfrAngeluX-Soft"
MsgBox sStr1 & vbCrLf & sStr2
lpStr = mMemory.cloneString(VarPtr(sStr2), sStr1) ' <--------------------- clone sStr1.
MsgBox sStr1 & vbCrLf & sStr2
Call mMemory.swapVarPtr(VarPtr(lpStr), VarPtr(sStr2)) ' // restauramos.
MsgBox sStr1 & vbCrLf & sStr2
Call mMemory.releaseMemStr(lpStr) ' // liberamos la copia de sStr1 (release sStr1 clone)
' // Other example.
Dim sStr3 As String
Dim lpSafe As Long
lpSafe = mMemory.allocMem((LenB(sStr1) + 4 + 2))
lpStr = (mMemory.getMemData(lpSafe) + 4)
Call mMemory.writeMemory((lpStr - 4), (StrPtr(sStr1) - 4), (LenB(sStr1) + 4 + 2))
Call mMemory.swapVarPtr(VarPtr(sStr3), VarPtr(lpStr))
MsgBox "ejemplo 2: " & sStr3
Call mMemory.swapVarPtr(VarPtr(sStr3), VarPtr(lpStr))
mMemory.releaseMem (lpSafe) ' // liberamos la memoria reservada con allocMem()
MsgBox "ejemplo 2 Finish: " & sStr3
End Sub
Option Explicit
Private Sub Form_Load()
Dim sStr1 As String
Dim sStr2 As String
Dim lpStr As Long
Dim i As Long
Dim a As Byte
Call mMemory.Initialize
sStr1 = "BlackZeroX"
sStr2 = "InfrAngeluX-Soft"
MsgBox sStr2 & vbCrLf & sStr1
MsgBox mMemory.writeMemory(StrPtr(sStr2) + 8, StrPtr(sStr1) + 10, 10)
MsgBox sStr2 & vbCrLf & sStr1
End Sub
'---------------------------------------------------------------------------------------
' 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
Cita de: Constance en 2 Noviembre 2011, 15:42 PM
En fin, tengo que decirlo , soy católica pero lo que entiende la Iglesia Católica por fiesta y lo que entiendo yo ....no tiene nada que ver ...
Cita de: seba123neo en 2 Noviembre 2011, 16:52 PM
otro de los mitos que se dicen es que si uno programa en VB6 despues le cuesta entender otros lenguajes, eso es otro mito, yo aprendi .NET y Java sin dificultad.
Albert Einstein