Bueno, me gustaria aportar con algo que hice hace un tiempo, pero en realidad no se si sera de utilidad (tampoco se si ya se ha hecho con anterioridad).
Como saben cuando VB llama a una API, ejecuta una secuencia de codigo muy particular. Algo como esto:
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
Basicamente lo que hace es verificar el valor que hay en la posicion de memoria 4032E8. Si hay un cero, entonces llama a DllFunctionCall para cargar la DLL (si en necesario) y luego usa GetProcAdress para obtener la direccion de la API. Al final, copia la direccion de la funcion a la direccion 4032E8.
Ahora, la idea es cargar cualquier codigo ASM en memoria usando VirtualAlloc y VirtualProtect; luego definir una funcion API llamada que sera la que ejecute el codigo
En realidad los parametros y el valor de retorno deben calcularse con Olly (u otro Debugger), pero eso es otra historia
Ahora, el siguiente codigo es del modulo que se encarga de hacer todo el trabajo.
Importante: El codigo ASM que se ejecutara se encuentra en la sección de recursos del EXE. Esto lo hice asi simplemente por sencillez. Pero el codigo podria estar en cualquier parte.
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
Ahora, en otro modulo (o en el mismo) definimos la funcion que lo llamara:
Declare Sub VBSHL Lib "invisible.dll" (dest as Long, ByVal count as Byte)
'VBSHL: Hace lo mismo que SHL en ASM. Corre hacia la izquierda el valor de dest, la cantidad definida por count
Por ultimo, se llamaria a la funcion asi:
Private Sub Command1_Click()
Dim Numero As Long
'Carga API en VB
If Not loadAPI("VBSHL") Then
MsgBox "No se pudo cargar la API! (Esto no funciona en el IDE de VB 6!)"
Exit Sub
End If
'carga los parametros de la API'
Numero = 10
'Llamamos a la API como la declaramos :)
VBSHL Numero, 1
If Numero = 20 Then
MsgBox "Funciona bien! :)"
Else
MsgBox "Error. No funciono :("
End If
'Liberar API
releaseAPI "VBSHL"
End Sub
Bueno, lo dejo por aca, a ver si sirve de algo...
Saludos!