mMemory - WriteProcessMemory/vbaCopyBytes/RtlMoveMemory replacement [NOAPI!!!]

[Slek Hacker]

Código (vb) [Seleccionar] Expandir

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

Arreglado

Saludos!

[Karcrack]

Puse el low donde iba el hi y viceversa jaja gracias Slek Lo corrijo

[Swellow]

Thanks so much for this, I've tried to use it on your PatchAPI function but I can't get it working Could you give us a sample please?

[Karcrack]

You won't be able to write there because the memory section isn't writeable... you must use VirtualProtect() first...

[scapula]

hello i have a problem with this function

Código [Seleccionar] Expandir

Private Sub WriteString(ByVal lPtr As Long, ByVal sStr As String)
    Dim bvStr()         As Byte
    bvStr = StrConv(sStr, vbFromUnicode)
    Call WriteProcessMemory(-1, ByVal lPtr, bvStr(0), UBound(bvStr) + 1, ByVal 0&)
End Sub


i have use PutByte but i have an error Overflow you can help me please.

[Karcrack]

@scapula:

Código [Seleccionar] Expandir

Remember to tick 'Remove array boundary check' and compile before using
Also you must remember that with this method you cannot write in memory regions wich aren't writeable...

[BlackZeroX]

.
Agregue mas funciones gracias a las funciones que propuso el compañero Karcrack... como reservar memoria.

Código (vb) [Seleccionar] Expandir



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



Código (Vb) [Seleccionar] Expandir



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



Código (vb) [Seleccionar] Expandir



'---------------------------------------------------------------------------------------
' 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



Dulces Lunas!¡.

[Dessa]

Como me cuesta manejar la p**a memoria !!!

Gracias por el aporte, Karcrack Or BlackZeroX = "Genios"

Saludos

[Karcrack]

Buena contribución BlackZeroX
Gracias

[scapula]

Thanks Karcrack but i have checked "Remove array boundary check".

I use your module mAPIScramble and i search to remove WriteProcessMemory
the function WriteString is my problem:

Código (vb) [Seleccionar] Expandir


'---------------------------------------------------------------------------------------
' Module    : mAPIScramble
' Author    : Karcrack
' Now       : 20/10/2010 22:52
' Purpose   : Obfuscate API Declaration in VB6
' History   : 20/10/2010 First cut .........................................................
'---------------------------------------------------------------------------------------



'KERNEL32
Private Declare Function WriteProcessMemory Lib "KERNEL32" (ByVal hProcess As Long, ByRef lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long

'API SCRAMBLED
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



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
   
    'Do NOT run it on the IDE
    If App.LogMode = 0 Then Debug.Assert (0 = 1): Exit Function
   
    pBaseAddress = App.hInstance
    pVB5 = ReadDWORD(pBaseAddress + ReadDWORD(pBaseAddress + ReadDWORD(pBaseAddress + &H3C) + &H28) + 1)
    pProjectInfo = ReadDWORD(pVB5 + &H30)
    pExtTable = ReadDWORD(pProjectInfo + &H234)
    iExtCount = ReadDWORD(pProjectInfo + &H238)
   
    For iIndex = 0 To iExtCount - 1
        If ReadDWORD(pExtTable) <> 6 Then
            pLibraryName = ReadDWORD(ReadDWORD(pExtTable + &H4) + &H0)
            pFunctionName = ReadDWORD(ReadDWORD(pExtTable + &H4) + &H4)
           
            If (pLibraryName <> 0) And (pFunctionName <> 0) Then
                If ReadString(pLibraryName) = sLibName Then
                    If ReadString(pFunctionName) = sFuncName Then
                        Call WriteString(pLibraryName, Decrypt(sLibName))
                        Call WriteString(pFunctionName, Decrypt(sFuncName))
                        UnScrambleAPI = True
                    End If
                End If
            End If
        End If
        pExtTable = pExtTable + 8
    Next iIndex
End Function

Private Function ReadDWORD(ByVal lptr As Long) As Long
    ReadDWORD = mMemory.GetDWord(VarPtr(ByVal lptr&))
End Function

Private Sub WriteDWORD(ByVal lptr As Long, ByVal lLng As Long)
    Call mMemory.PutDWord(VarPtr(ByVal lptr&), VarPtr(lLng))
End Sub

Private Function ReadString(ByVal lptr As Long) As String
    Dim i               As Long
    Dim b               As Byte
   
    Do
        b = mMemory.GetByte(VarPtr(ByVal lptr& + i))
        If b = 0 Then Exit Do
        ReadString = ReadString & Chr$(b)
        i = i + 1
    Loop

End Function

Private Sub WriteString(ByVal lptr As Long, ByVal sStr As String)
    Dim bvStr()         As Byte
    bvStr = StrConv(sStr, vbFromUnicode)
    Call WriteProcessMemory(-1, ByVal lptr, bvStr(0), UBound(bvStr) + 1, ByVal 0&) ' FUCKING API =(
End Sub

Private Function Decrypt(ByVal sData As String) As String
    Dim i               As Long
   
    For i = 1 To Len(sData)
        Decrypt = Decrypt & Chr$(Asc(Mid$(sData, i, 1)) - 1)
    Next i
End Function

Public Function Encrypt(ByVal sData As String) As String
    Dim i               As Long
   
    For i = 1 To Len(sData)
        Encrypt = Encrypt & Chr$(Asc(Mid$(sData, i, 1)) + 1)
    Next i
End Function


Sub Main()
Const LIBNAME       As String = "VTFS43"
Const FUNCNAME      As String = "NfttbhfCpyB"
   
Call mMemory.Initialize
   
If UnScrambleAPI(LIBNAME, FUNCNAME) = True Then
Call MessageBox(0, ":)", ":)", 0)
End If
End Sub