Foro de elhacker.net

http://foro.elhacker.net/programacion_vb/sourceactualizado_karcrack_project_crypter_encripta_tus_proyectos_en_vb-t221869.0.html
http://foro.elhacker.net/analisis_y_diseno_de_malware/karcrack_project_crypter_v21_kpc-t256127.0.html

http://foro.elhacker.net/analisis_y_diseno_de_malware/taller_asi_funcionan_los_crypters_encriptando_malware_a_mano-t262806.0.html

MOV EAX,DWORD PTR DS:[4032E8]
OR EAX,EAX
JE SHORT Proyecto.00401AEB
JMP EAX
PUSH Proyecto.00401AC8
MOV EAX,<JMP.&MSVBVM60.DllFunctionCall>
CALL EAX
JMP EAX

Attribute VB_Name = "modResASMAPI"
Option Explicit
'---------------------------------------------------------------------------------------
' Module      : modResAsmAPI
' DateTime    : 19/10/2009 20:15
' Author      : MCKSys Argentina
' Mail        : nop
' WebPage     : nop, thanks
' Purpose     : Call ASM code inside VB
' Usage       : At your own risk
' Requirements: none
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
'
' Thanks To   : Rivardo Narvaja, Solid [CLS]... and everyone at CrackslatinoS !
'
' History     : 19/10/2009 First Release................................................
'---------------------------------------------------------------------------------------

'PLEASE EXCUSE MY BAD ENGLISH!!!

Public Const MEM_COMMIT = &H1000
Public Const MEM_RESERVE = &H2000
Public Const MEM_DECOMMIT = &H4000
Public Const MEM_RELEASE = 32768 '&H8000
Public Const PAGE_EXECUTE_READWRITE = &H40
Private Const VBHeaderConst = &H21354256 '"VB5!"
Public Declare Function VirtualAlloc Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Public Declare Function VirtualFree Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32" (dest As Any, src As Any, ByVal L As Long)

Private Type tASMProc
    Nombre As String
    Addr As Long
    Size As Long
End Type

Dim procAddrArray() As tASMProc
Dim procAddrArrayIdx As Long

Function loadAPI(Nombre As String) As Boolean
'loadAPI: Loads ASM code from resource named "Nombre" and points the VB declared API (with the same name)
'         to loaded ASM code
Dim ASMproc() As Byte
Dim procAddr As Long

Err.Clear
On Error GoTo Hell

'load ASM code from resources
ASMproc = LoadResData(Nombre, "CUSTOM")
'create section in memory to copy ASM code
'Note the PAGE_EXECUTE_READWRITE flag!
procAddr = VirtualAlloc(ByVal 0, UBound(ASMproc) + 1, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If procAddr = 0 Then
    MsgBox "loadAPI: Unable to reserve memory!" 'you can delete this...
    loadAPI = False
    Exit Function
End If
'copy ASM code to section
RtlMoveMemory ByVal procAddr, ASMproc(0), UBound(ASMproc) + 1
'update array of procs to release memory when we're finish
If procAddrArrayIdx > 0 Then
    procAddrArrayIdx = procAddrArrayIdx + 1
End If
ReDim Preserve procAddrArray(procAddrArrayIdx)
procAddrArray(procAddrArrayIdx).Addr = procAddr
procAddrArray(procAddrArrayIdx).Nombre = UCase(Nombre)
procAddrArray(procAddrArrayIdx).Size = UBound(ASMproc) + 1
'patch EXE in memory to make declared API to point to our loaded code
If Not patchVBAPI(Nombre, procAddr) Then
    MsgBox "loadAPI: Unable to patch EXE in memory!" 'you can delete this...
    loadAPI = False
    Exit Function
End If
'all ok, return true
loadAPI = True
Exit Function
Hell:
    'failure :(
    MsgBox "loadAPI: " & Err.Description 'you can delete this...
    loadAPI = False
End Function

Function releaseAPI(Nombre As String) As Boolean
'releaseAPI: Releases loaded ASM code form memory and points the VB declared API (with the same name)
'            to "nothing"

Dim I As Long
Dim J As Long
Dim procAddr As Long
Dim procSize As Long

Err.Clear
On Error GoTo Hell

'patch EXE in memory to make declared API to point to nothing
If Not patchVBAPI(Nombre, 0) Then
    MsgBox "loadAPI: Imposible parchear Ejecutable!"
    releaseAPI = False
    Exit Function
End If
'update array of procs to release memory when we're finish
If procAddrArrayIdx = 0 Then
    'save memory address and size of proc to release it later
    procAddr = procAddrArray(procAddrArrayIdx).Addr
    procSize = procAddrArray(procAddrArrayIdx).Size
    ReDim procAddrArray(procAddrArrayIdx)
Else
    For I = 0 To UBound(procAddrArray) - 1
        If (procAddrArray(I).Nombre = UCase(Nombre)) Then
            'save memory address and size of proc to release it later
            procAddr = procAddrArray(I).Addr
            procSize = procAddrArray(I).Size
            For J = I To UBound(procAddrArray) - 2
                procAddrArray(J) = procAddrArray(J + 1)
                GoTo Seguir
            Next J
        End If
    Next I
Seguir:
    procAddrArrayIdx = procAddrArrayIdx - 1
    ReDim Preserve procAddrArray(procAddrArrayIdx)
End If
'release created section in memory (where ASM code is)
I = VirtualFree(ByVal procAddr, procSize, MEM_DECOMMIT)
If I = 0 Then
    MsgBox "releaseAPI: Unable to Decommit memory!" 'you can delete this...
    releaseAPI = False
    Exit Function
End If
I = VirtualFree(ByVal procAddr, 0, MEM_RELEASE)
If I = 0 Then
    MsgBox "releaseAPI: Unable to release memory!" 'you can delete this...
    releaseAPI = False
    Exit Function
End If
'all ok, return true
releaseAPI = True
Exit Function
Hell:
    'failure
    MsgBox "releaseAPI: " & Err.Description 'you can delete this...
    releaseAPI = False
End Function

Function getVBHeader(AddrProc As Long) As Long
'Searches and returns address of VBHeader struct from memory, starting from "AddrProc"
'Returns 0 ifnot founded or error

Dim Buffer As Long
Dim ImageBaseNormal As Long
Dim I As Long

ImageBaseNormal = AddrProc - CLng("&H" + Right(Hex(AddrProc), 4))
If AddrProc <= ImageBaseNormal Then
    'not logic!
    getVBHeader = 0
Else
    I = AddrProc
    Do While I > ImageBaseNormal
        RtlMoveMemory Buffer, ByVal I, &H4
        If Buffer = VBHeaderConst Then
            'VBHeader founded!
            getVBHeader = I
            Exit Function
        End If
        I = I - 4
    Loop
End If
'not founded
getVBHeader = 0
End Function

Public Function patchVBAPI(Nombre As String, AddrProc As Long) As Boolean
'Patches the declared API (Nombre) to point to the AddrProc address
Dim offsetExternalTable As Long
Dim offsetVBHeader As Long
Dim ExternalCount As Long
Dim vbAPIVar As Long
Dim parche(4) As Byte
Dim I As Long
Dim J As Long
Dim K As Long
Dim strAux As String

Err.Clear
On Error GoTo Salida

offsetVBHeader = getVBHeader(AddressOf releaseAPI)

'are we in the VB IDE?
If offsetVBHeader = 0 Then GoTo Salida

offsetExternalTable = GetDwordAt(offsetVBHeader + &H30) + &H234

ExternalCount = 0
ExternalCount = GetDwordAt(offsetExternalTable + 4)
K = GetDwordAt(offsetExternalTable)

For I = 1 To ExternalCount
    If GetByteAt(K) <> 6 Then
        J = GetDwordAt(K + 4)
        strAux = UCase(GetANSIStrAt(GetDwordAt(J + 4)))
        If strAux = UCase(Nombre) Then
            vbAPIVar = GetDwordAt(J + &H19)
            RtlMoveMemory ByVal vbAPIVar, AddrProc, &H4
            Exit For
        End If
    End If
    K = K + 8
Next I
patchVBAPI = True
Exit Function
Salida:
    patchVBAPI = False
End Function

Private Function DWHexFill(xDword As Long) As String
Dim strAux As String

strAux = Hex(xDword)
DWHexFill = String(8 - Len(strAux), "0") + strAux
End Function

Private Function HexFill(xByte As Byte) As String
Dim strAux As String
strAux = Hex(xByte)
If Len(strAux) = 1 Then
    strAux = "0" + strAux
End If
HexFill = strAux
End Function

Private Function GetANSIStrAt(Posicion As Long) As String
Dim I As Long
Dim car As Byte
Dim strAux As String

strAux = ""
I = Posicion
car = GetByteAt(I)
Do While car <> 0
    strAux = strAux + Chr(car)
    I = I + 1
    car = GetByteAt(I)
Loop
GetANSIStrAt = strAux
End Function

Private Function GetByteAt(Posicion As Long) As Byte
Dim lAux As Byte

RtlMoveMemory lAux, ByVal Posicion, &H1
GetByteAt = CByte("&H" + HexFill(lAux))
End Function

Private Function GetDwordAt(Posicion As Long) As Long
Dim lAux As Long

RtlMoveMemory lAux, ByVal Posicion, &H4
GetDwordAt = CLng("&H" + DWHexFill(lAux))
End Function