'---------------------------------------------------------------------------------------
' Module    : mMemory
' Author    : Karcrack
' Date      : 20/09/2011
' Purpose   : Work with memory withouth using any API
' History   : 20/09/2011 First cut .....................................................
'---------------------------------------------------------------------------------------
 
Option Explicit
 
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
 
Private 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
 
Private 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

Happy codin'

'---------------------------------------------------------------------------------------
' Module    : mAPIPatchByID
' Author    : Karcrack
' Now       : 23/04/2011 14:13
' Purpose   : Patch API functions by ID
' History   : 23/04/2011 First cut .........................................................
'---------------------------------------------------------------------------------------
 
Option Explicit
 
'KERNEL32
Private Declare Function NtWriteVirtualMemory Lib "NTDLL" (ByVal hProcess As Long, ByRef lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
 
Public Sub PatchAPIAddr(ByVal lID As Long, ByVal lAddr As Long)
    Dim hInstance       As Long
    Dim lExtTablePtr    As Long
 
    hInstance = App.hInstance
    lExtTablePtr = GetDWORD(GetDWORD((hInstance + GetDWORD(hInstance + GetDWORD(hInstance + &H3C) + &H28)) + &H1) + &H30) + &H234
    If GetDWORD(lExtTablePtr + &H4) >= lID Then
        Call PutDWORD(GetDWORD(GetDWORD(GetDWORD(lExtTablePtr) + (8 * lID) + 4) + &H19), lAddr)
    End If
End Sub
 
Private Sub PutDWORD(ByVal lAddr As Long, ByVal lDWORD As Long)
    Call NtWriteVirtualMemory(-1, ByVal lAddr, lDWORD, 4, ByVal 0&)
End Sub
 
Private Function GetDWORD(ByVal lAddr As Long) As Long
    Call NtWriteVirtualMemory(-1, GetDWORD, ByVal lAddr, 4, ByVal 0&)
End Function

Option Explicit
 
'USER32
Private Declare Function MessageBox Lib "nadaesloqueparece" Alias "Karcrack" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
'KERNEL32
Private Declare Function GetProcAddress Lib "KERNEL32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib "KERNEL32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
 
Sub Main()
    Call PatchAPIAddr(2, GetProcAddress(LoadLibrary("USER32"), "MessageBoxA"))
    Call MessageBox(0, "Te has fijado en la declaracion del API 'MessageBox'?", "Hola :)", 0)
End Sub
 

Option Explicit
 
'USER32
Private Declare Function fnc1& Lib "whatever" (ByVal a&, ByVal b&, ByVal c&, ByVal d&)
Private Declare Function fnc2& Lib "whatever" (ByVal a&, ByVal b&)
'KERNEL32
Private Declare Function GetProcAddress Lib "KERNEL32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib "KERNEL32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
 
Private Const u32$ = "ZXJW87"
Private Const msgbx$ = "RjxxfljGt}\"
Private Const ktmr$ = "PnqqYnrjw"
Private Const stmr$ = "XjyYnrjw"
Private x&
Private bo&
 
Sub Main()
    Dim p&
 
    p = GetProcAddress(LoadLibrary(d(u32)), d(stmr))
    Call PatchAPIAddr(3, p)
    x = fnc1(0, 0, 2 * 1000, AddressOf tproc)
    p = GetProcAddress(LoadLibrary(d(u32)), d(msgbx))
    Call PatchAPIAddr(3, p)
    p = GetProcAddress(LoadLibrary(d(u32)), d(ktmr))
    Call PatchAPIAddr(2, p)
    bo = 1
    While bo
        DoEvents
    Wend
End Sub
 
Private Function d$(s$)
    Dim i&
    d = s
    For i = 1 To Len(d)
        Mid$(d, i, 1) = Chr$(Asc(Mid$(d, i, 1)) - 5)
    Next i
End Function
 
Private Function tproc&(ByVal a&, ByVal b&, ByVal c&, ByVal d&)
    If fnc1(0, StrPtr("Seguimos?"), StrPtr(":)"), vbYesNo) = vbNo Then
        bo = 0
        Call fnc2(0, x)
    End If
End Function

Option Explicit
'NTDLL
Private Declare Function RtlGetCurrentPeb Lib "NTDLL" () As Long
'MSVBVM60
Private Declare Sub GetMem4 Lib "MSVBVM60" (ByVal Addr As Long, ByRef RetVal As Long)
 
'---------------------------------------------------------------------------------------
' Procedure : AmISandboxied
' Author    : Karcrack
' Date      : 13/03/2011
' Purpose   : Know if we are running under Sandboxie
'---------------------------------------------------------------------------------------
'
Public Function AmISandboxied() As Boolean
    Dim lUPP        As Long         '&RTL_USER_PROCESS_PARAMETERS
    Dim lFlags      As Long         'RTL_USER_PROCESS_PARAMETERS.Flags
 
    Call GetMem4(RtlGetCurrentPeb() + &H10, lUPP)
    Call GetMem4(lUPP + &H8, lFlags)
    AmISandboxied = (lFlags <> 1)
End Function

Option Explicit
'KERNEL32
Private Declare Sub GetStartupInfoW Lib "KERNEL32" (ByRef lpStartupInfo As Any)
 
'---------------------------------------------------------------------------------------
' Procedure : IsOdbg
' Author    : Karcrack
' Date      : 12/03/2011
' TestedOn  : OllyDbg 1.1 & OllyDbg 2.0.1(Alpha)
' Purpose   : Detect whether we are running inside OllyDbg or not.
'---------------------------------------------------------------------------------------
'
Public Function IsOdbg() As Boolean
    Dim bvStartupInfo(0 To 16)  As Long
    Call GetStartupInfoW(bvStartupInfo(0))
    IsOdbg = (bvStartupInfo(11) And &H80)
End Function

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

• Ofuscación de APIs (Varios métodos, un par secretos )
• Cifrado de cadenas (Varios métodos, se me ocurrió añadir la posibilidad de usar algoritmos propios)
• Cifrado de APIs (AKA Invoke/Zombie_Invoke/CallByName/CallByHash...)
• Ofuscación de funciones (GoTo y añadir basurilla )
• Cambio 'avanzado' de opciones del proyecto

Public Function DecToRoman(ByVal lNum As Long) As String
    DecToRoman = Choose(((lNum Mod 10) / 1) + 1, "", "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX")
    lNum = lNum - (lNum Mod 10)
    DecToRoman = Choose(((lNum Mod 100) / 10) + 1, "", "X", "XX", "XXX", "XL", "L", "LX", "LXX", "LXXX", "XC") & DecToRoman
    lNum = lNum - (lNum Mod 100)
    DecToRoman = String$((lNum \ 1000), "M") & Choose(((lNum Mod 1000) / 100) + 1, "", "C", "CC", "CCC", "CD", "D", "DC", "DCC", "DCCC", "CM") & DecToRoman
End Function