用机器码注入实现VB6回调函数功能，并支持自定义函数功能。

zhongez

在编译成native exe 后可实现回调函数的功能，不依赖DLL库。I立即回调，比通常通过callwindowproc实现快多了。
使用场景是需要高速回调的场合，比如模拟cpu指令的高速查表解码。在ide模式不支持，可以用callwindowsproc或我提供的callback.dll代替。
同时支持自定义虚函数，用实现不同功能的机器码自动替换掉，操作简单就一行代码。obj.InjectCode AddressOf 函数名, 机器码串。
form1窗体代码：
Option Explicit
'支持四个long参数的回调函数机器码
Const patchHex = "8B 44 24 04 8B 4C 24 08 8B 54 24 0C 8B 74 24 10 8B 7C 24 14 57 56 52 51 FF D0 C2 14 00"

Private Sub Command1_Click()
Dim Addptr As Long
Dim Mulptr As Long

Dim obj As New ClsInjectCode
'/////注入回调函数代码  ////
obj.InjectCode AddressOf Callback, patchHex
'///// 取范例函数指针                       /////
'///// 遗憾的是vb只能硬编码取得函数入口指针  ////
Addptr = GetAddr(AddressOf FAdd)
Mulptr = GetAddr(AddressOf FMul)
'///// 回调测试  ////////
Callback Addptr, 1, 2, 3, 4  '加法
Callback Mulptr, 1, 2, 3, 4  '乘法
Callback Addptr, 1, 2, 3, 4  '加法
Callback Mulptr, 1, 2, 3, 4  '乘法
Set obj = Nothing

End Sub

公共模块代码
Option Explicit
'//////////////////////////////////////////////////////////////
'//// callback 函数是个虚函数，代码无意义只为分配内存空间  ////
'//// 参数布局 模仿 callwindowproc 的参数格式              ////
'//////////////////////////////////////////////////////////////
Public Function Callback(ByVal addr As Long, ByVal a As Long, ByVal b As Long, _
                         ByVal c As Long, ByVal d As Long) As Long
Dim r As Long
r = a + b + c + d
r = a + b + c + d
r = a + b + c + d
Callback = r
End Function
'/// 测试范例： 加法 /////
Public Function FAdd(ByVal a As Long, ByVal b As Long, _
                         ByVal c As Long, ByVal d As Long) As Long
Dim r As Long
r = a + b + c + d
MsgBox "加法：" & a & " + " & b & " + " & c & " + " & d & " = " & r
FAdd = r
End Function

'/// 测试范例： 乘法 /////
Public Function FMul(ByVal a As Long, ByVal b As Long, _
                         ByVal c As Long, ByVal d As Long) As Long
Dim r As Long
r = a * b * c * d
MsgBox "乘法：" & a & " * " & b & " * " & c & " * " & d & " = " & r
FMul = r

End Function

'////// 返回通过 addressof 传入的函数指针   ////
Public Function GetAddr(ByVal addr As Long) As Long
GetAddr = addr

End Function



类模块ClsInjectCode代码：
Option Explicit
' 修改内存保护属性（使代码段可写）
Private Declare Function VirtualProtect Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flNewProtect As Long, _
    lpflOldProtect As Long) As Long

' 拷贝内存（用于写入机器码）
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByVal Destination As Long, _
    ByRef Source As Any, _
    ByVal Length As Long)

' 记录最后一次注入地址和机器码
Private mLastAddress As Long
Private mLastHexCode As String
Private Const PAGE_EXECUTE_READWRITE As Long = &H40

'//// 代码注入接口  //////
Public Sub InjectCode(ByVal addr As Long, ByVal hexStr As String)
    Dim patch() As Byte
    patch = HexStringToBytes(hexStr)
    Call ModifyFun(addr, patch)
    mLastAddress = addr
    mLastHexCode = hexStr
End Sub

'//////// 机器码字符串转成byte数组 /////
Private Function HexStringToBytes(hexStr As String) As Byte()
    Dim parts() As String
    Dim result() As Byte
    Dim i As Long

    parts = Split(Trim$(hexStr))
    ReDim result(0 To UBound(parts))

    For i = 0 To UBound(parts)
        result(i) = CByte("&H" & parts(i))
    Next

    HexStringToBytes = result
End Function

'////// 机器码注入  //////
Private Sub ModifyFun(ByVal addr As Long, patch() As Byte)
    Dim patchLength As Long
    patchLength = UBound(patch) - LBound(patch) + 1

    Dim oldProtect As Long
    Call VirtualProtect(addr, patchLength, &H40, oldProtect)
    Call CopyMemory(ByVal addr, ByVal VarPtr(patch(LBound(patch))), patchLength)
    Call VirtualProtect(addr, patchLength, oldProtect, oldProtect)
End Sub

配合IDE模式下调试的回调函数Dll库C代码,可自己编译：
编译后在VB的声明格式：
Private Declare Sub Callback Lib "Callback.dll" Alias "_Callback@20" _
      (ByVal addr As Long, ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long)


#include <windows.h>

// 定义回调函数类型
typedef void (__stdcall *CallbackFunc)(int,int,int,int);

// 设置回调并立即执行
__declspec(dllexport) void __stdcall Callback(CallbackFunc cb, int a, int b,int c,int  d) {
    if (cb) {
        cb(a, b, c, d);  // 立即回调，传入调用者参数
    }
}

zhongez

这是编译好的Callback.dll回调函数库

zhongez

测试发现一个问题，在编译时不能选择速度优化，不然程序会跑飞。
'====================================================
'=====   通过测试，发现VB6 编译时，选择代码优化或速度优化时       ====
'=====   不同名的函数，如果参数和返回值都一样，函数体运行逻辑也一样     ====
'=====    在编译时会被处理成一个同样的入口指针                                          ====
'====================================================
这个是修复后的版本，编译选速度优化和代码优化都正常
form1：


Private Sub Command2_Click()
Dim obj As Class1
Set obj = New Class1

'写入添加多个代码段是否会被覆盖
'若覆盖倒数第二条的回调功能必然失败
'==============================================================================
'=====    !!! 通过这次测试，发现VB6 编译时，选择代码优化或速度优化时       ====
'=====    不同名的函数，如果参数和返回值都一样，函数体运行逻辑也一样       ====
'=====    在编译时会被处理成一个同样的入口指针                             ====
'=====    函数Testadd4 和 Callback 刚好遇到这种情况，加条语句避坑          ====
'==============================================================================

obj.start AddressOf Testadd4, AsmTestadd4
obj.start AddressOf callback, AsmCallback
obj.start AddressOf callback, AsmTestadd4
obj.start AddressOf Testadd4, AsmTestadd4
obj.start AddressOf callback, AsmCallback
obj.start AddressOf Testadd4, AsmTestadd4

Dim result As Long '
'直接计算测试
result = Testadd4(10, 20, 30, 40, 50)
MsgBox "直接计算结果应返回140: = " & result

'回调函数计算
result = callback(AddressOf ByCallbackFunc, 10, 200, 3000, 40000)
MsgBox "回调执行应返回432100 :  " & result

End Sub
--------------------
标准模块:

Option Explicit
Public AsmCode() As Byte '用数组仿内存，存储用户代码段


'回调函数代码：输入5个long参数，并回调出后面4个参数的回调函数机器码
'本代码段没有带寄存器压栈保护，性能高点，stallcall 没有问题
'Public Const AsmCallback = _
'"8B 44 24 14 50 8B 44 24 14 50 8B 44 24 14 50 8B 44 24 14 50 8B 44 24 14 FF D0 C2 14 00"

'==== 下面这段测试有带寄存器压栈保护，根据需要选择  ===
Public Const AsmCallback = _
"53 56 57 51 52 8B 44 24 28 50 8B 44 24 28 50 8B 44 24 28 50 8B 44 24 28 50 8B 44 24 28 FF D0 5A 59 5F 5E 5B C2 14 00"

'支持后四个long参数的求和直接计算函数原型机器码
Public Const AsmTestadd4 = "8B 44 24 08 03 44 24 0C 03 44 24 10 03 44 24 14 C2 14 00"


'///// 回调函数接口定义 ，通过汇编实现 ////
Public Function callback(ByVal addr As Long, ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long) As Long

'这条只为避免编译时，函数体接口和逻辑相同被优化成同一个入口，比如下面的Testadd4。
MsgBox "看到这就没有进入回调"
End Function

'///// 求和函数接口定义：通过汇编计算  ////
Public Function Testadd4(ByVal addr As Long, ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long) As Long
End Function

'//////  测试范例：通过callback回调间接执行  ////
Public Function ByCallbackFunc(ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long) As Long

Dim result As Long
MsgBox "现在在被回调函数中,传入参数为：" & a & " " & b & " " & c & " " & d
result = (a + b + c + d) * 10
ByCallbackFunc = result
End Function
------------------
类模块：
Option Explicit

' ===== API 声明 =====

Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

Private Declare Function VirtualAlloc Lib "kernel32" ( _
    ByVal lpAddress As Long, _
    ByVal dwSize As Long, _
    ByVal flAllocationType As Long, _
    ByVal flProtect As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByVal Destination As Long, _
    ByVal Source As Long, _
    ByVal length As Long)

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long

   
Dim MAXLength As Long          '最大可存储字节数
'Dim AsmCode() As Byte         '用数组仿真内存存储代码段
Dim SlidePtr As Long           '当前可用空间首地址
Dim RemainLength As Long       '剩余可用机器码空间
Dim tempCode() As Byte         '字符串转机器码数据暂存
Dim SaveCodeFlag  As Boolean   '写机器码到内存是否成功标志



Private Sub Class_Initialize()
'申请2k可用空间
'采用硬编码不够自己修改，能写2k的机器码也不是一般人
'不想写属性接口，让引用初始化简单点。

MAXLength = 2048   '2K

ReDim AsmCode(MAXLength - 1)
SlidePtr = 0
RemainLength = MAXLength
End Sub


Public Sub start(ByVal addr As Long, ByVal HexStr As String)
'处理字符串
Call HexStringToBytes(HexStr)

'字节码写入内存空间
Call SaveHexCodetoArray
If Not SaveCodeFlag Then Exit Sub  '写入失败即退出
''''' 修改函数jmp
Call changeCalltoJmp(ByVal addr)

RemainLength = RemainLength - UBound(tempCode) - 1 '修正剩余空间
SlidePtr = SlidePtr + UBound(tempCode) + 1         '移动滑动指针

ReDim tempCode(0)  '回收临时代码空间


End Sub

'//////// 机器码字符串转成byte数组 /////
Private Sub HexStringToBytes(HexStr As String)
    Dim parts() As String
    Dim result() As Byte
    Dim i As Long
    '！！！这里本要错误检测处理，检查输入参数hexstr是否为空或是有效机器码！！
    '！！！配合开发程序内部使用，自己控制机器码串正确性。
    parts = Split(Trim$(HexStr))
   
    ReDim tempCode(0 To UBound(parts))
    For i = 0 To UBound(parts)
        tempCode(i) = CByte("&H" & parts(i))
    Next

End Sub

' /////// 机器码保存到内存   //////

Private Sub SaveHexCodetoArray()
Dim length As Long
length = UBound(tempCode) + 1
If length > RemainLength Then
    MsgBox ("可用空间不足！")
    SaveCodeFlag = False
    Exit Sub
End If
Dim i As Long

For i = 0 To UBound(tempCode)
    AsmCode(SlidePtr + i) = tempCode(i)
Next

SaveCodeFlag = True
End Sub



'///////////// 将callback函数的call指令  改为  jmp  //////////////
Private Sub changeCalltoJmp(ByVal Funcaddr As Long)
Dim patchAddr(5) As Byte                            'jmp 指令需要五个字节
Dim oldProtect As Long
Dim TargetAddress As Long
Dim offset As Long

TargetAddress = VarPtr(AsmCode(SlidePtr))           '取机器代码入口地址
patchAddr(0) = &HE9                                 'jmp 首字节
offset = TargetAddress - (Funcaddr + 5)             '计算待修改函数和入口地址偏移量，jmp跳转到byte数组
CopyMemory VarPtr(patchAddr(1)), VarPtr(offset), 4  '写4个字节偏移地址

'解锁待处理函数分配call指令的5个字节内存空间改写成jmp指令再上锁。
Call VirtualProtect(Funcaddr, 5, &H40, oldProtect)
Call CopyMemory(Funcaddr, VarPtr(patchAddr(0)), 5)
Call VirtualProtect(Funcaddr, 5, oldProtect, oldProtect)

End Sub

gujin163

感谢大佬分享~~

0xAA55

我觉得这个操作最有意义的用法是针对数学库进行优化。数学计算，包括浮点数的向量计算，矩阵计算等，可以优化为 SSE、SSE2 指令编写的计算。先用 VB6 编写原始实现（正常用 Single、Double 做 + - * / 计算），并且尽量写的啰嗦，好让「优化为速度」的时候，生成更多的代码，为替换 SSE、SSE2 的实现腾出空间。再在编译为 EXE 的时候，先检测是 IDE 运行还是 EXE 运行，如果是 EXE 运行，就把准备好了的 SSE 指令代码替换到原始函数上。可以通过检测 ret 指令的位置，来检测原始函数的字节长度，再判断是否容纳得下替换后的实现。如果容纳不下，那就分配内存，然后把原始函数的开头改为 jmp 跳转到分配好了的内存，然后把 SSE 指令写到分配的内存上。