通过修改COM对象VTable来执行任意函数（真的是任意哦）的研究。希望能有很多人来参加研究

Question

以下是本人代码：
'----------------------- Form1.frm --------------------------------
'需要窗体上放一个名为Command1的按钮控件
Private m_lpVTable As Long
Private m_lpJmp As Long
Private lOldFunc As Long
Private lNewFunc As LongPrivate Sub Command1_Click()
    Dim oCaller As New CCaller
    Dim vRet As Variant
    
    m_lpVTable = GetLngValue(ObjPtr(oCaller))
    m_lpJmp = m_lpVTable + &H1C
    lOldFunc = GetLngValue(m_lpJmp)
    
    '本地函数测试
    'lNewFunc = FuncPtr(AddressOf TestFunction)
    'lNewFunc = FuncPtr(AddressOf TestSub)
    '外部函数测试
    Dim hMod As Long
    hMod = LoadLibrary("CallTest.dll")
    If hMod <> 0 Then
        lNewFunc = GetProcAddress(hMod, "CallInvoke")
        If lNewFunc = 0 Then            Debug.Print "no"
            Exit Sub        End If
    End If
    
    CopyMemory ByVal m_lpJmp, ByVal VarPtr(lNewFunc), 4 'paste in new address
    vRet = oCaller.Invoke(123)
    MsgBox "返回值:" & vRet
    CopyMemory ByVal m_lpJmp, ByVal VarPtr(lOldFunc), 4 'restore old function address
    
    If hMod <> 0 Then
        FreeLibrary hMod
    End If
End SubPrivate Sub Form_Load()
    '防止VB环境崩溃
    'Call InitExceptionHandler
End Sub'----------------------- CCaller.cls --------------------------------
Public Function Invoke(ByVal s As Long) As Long
End Function
'----------------------- mduCaller.bas --------------------------------
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Public Function GetLngValue(ByVal lAddress As Long) As Long
    CopyMemory GetLngValue, ByVal lAddress, 4
End FunctionPublic Function TestFunction(ByVal dumb As Long, ByVal s As String) As String
    Dim lParaCount As Long
    Dim lRetValueAddress As Long
    lParaCount = 1
    
    MsgBox "我是快乐的Function"
    
    TestFunction = "Hello"
    
    lRetValueAddress = GetLngValue(VarPtr(dumb) + (lParaCount + 1) * 4)
    CopyMemory ByVal lRetValueAddress, ByVal VarPtr(TestFunction), LenB(TestFunction)
End FunctionPublic Sub TestSub()
    MsgBox "我是快乐的Sub"
End SubPublic Function FuncPtr(ByVal ptr As Long) As Long
    FuncPtr = ptr
End Function'----------------------------------------------------------------------
'----------------------------------------------------------------------
'----------------------------------------------------------------------
'----------------------------------------------------------------------
'----------------------------------------------------------------------
'以下是我C测试函数
void WINAPI CallInvoke(int dumb,int value){
int iParamCount=1;
int** iRetAddress;    iRetAddress =(int **) &dumb+(iParamCount + 1);
    **iRetAddress=value;
}

Answer 1

关于防崩溃的代码模块在
http://expert.csdn.net/Expert/topic/2859/2859424.xml?temp=.896435

Answer 2

希望咱们VB板块里能兴起一股学习COM的热潮……

Answer 3

// 希望咱们VB板块里能兴起一股学习COM的热潮……這段代碼跟學習 COM 有什麽聯系？

Answer 4

外部 dll 測試沒問題，子過程測試也沒問題，
lNewFunc = FuncPtr(AddressOf TestSub)
不過測試函數時會出點問題，不知道綠荳兄那裏是不是這樣
lNewFunc = FuncPtr(AddressOf TestFunction)幫忙測試一下。

Answer 5

使用这种方法，目前我还只能使TestFunction 和Invoke方法的参数类型一致才可以，否则就会出现不是我们所希望的结果

Answer 6

'这是以二进制代码形式调用函数
'sByteCode就是上面那个C函数CallInvoke的字符型字节代码
'bBinCode就是CallInvoke的二进制代码
'由这里可以看到，在VB里确实可以实现嵌入部分汇编代码
Private Sub Command1_Click()
    Dim oCaller As New CCaller
    Dim vRet As Variant
    Dim sByteCode As String
    Dim bBinCode() As Byte
    
    sByteCode = "55 8B EC 83 EC 48 53 56 57 8D 7D B8 B9 12 00 00 00 B8 CC CC CC CC F3 AB C7 45 FC 01 00 00 00 8B 45 FC 8D 4C 85 0C 89 4D F8 8B 55 F8 8B 02 8B 4D 0C 89 08 5F 5E 5B 8B E5 5D C2 08 00"
    bBinCode = ByteCodeStrToBin(sByteCode)
    
    m_lpVTable = GetLngValue(ObjPtr(oCaller))
    m_lpJmp = m_lpVTable + &H1C
    lOldFunc = GetLngValue(m_lpJmp)    lNewFunc = VarPtr(bBinCode(0))
    
    CopyMemory ByVal m_lpJmp, ByVal VarPtr(lNewFunc), 4 'paste in new address
    vRet = oCaller.Invoke(321)
    MsgBox "返回值:" & vRet
    CopyMemory ByVal m_lpJmp, ByVal VarPtr(lOldFunc), 4 'restore old function address
End SubPublic Function ByteCodeStrToBin(ByVal sByteCode As String) As Byte()
    Dim s() As String
    Dim b() As Byte
    Dim i As Long
    
    s = Split(Trim(sByteCode), " ")
    
    If UBound(s) >= 0 Then
        ReDim b(UBound(s))
    End If
    
    For i = 0 To UBound(s)
        b(i) = CByte("&h" & s(i))
    Next
    ByteCodeStrToBin = b
End Function

Answer 7

我這裏有一段調用 API by Name 的例子，不知道你收藏過沒有：
' 以下代碼放在標准模塊裏
Option Explicit
'***********************************************
'* This module use excelent solution from
'* http://www.vbdotcom.com/FreeCode.htm
'* how to implement assembly calls directly
'* into VB code.
'***********************************************
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) 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
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Private mlngParameters() As Long 'list of parameters
Private mlngAddress As Long 'address of function to call
Private mbytCode() As Byte 'buffer for assembly code
Private mlngCP As Long 'used to keep track of latest byte added to codePublic Function CallApiByName(libName As String, funcName As String, ParamArray FuncParams()) As Long
   Dim lb As Long, i As Integer
   ReDim mlngParameters(0)
   ReDim mbytCode(0)
   mlngAddress = 0
   lb = LoadLibrary(ByVal libName)
   If lb = 0 Then
      MsgBox "DLL not found", vbCritical
      Exit Function
   End If
   mlngAddress = GetProcAddress(lb, ByVal funcName)
   If mlngAddress = 0 Then
      MsgBox "Function entry not found", vbCritical
      FreeLibrary lb
      Exit Function
   End If
   ReDim mlngParameters(UBound(FuncParams) + 1)
   For i = 1 To UBound(mlngParameters)
      mlngParameters(i) = CLng(FuncParams(i - 1))
   Next i
   CallApiByName = CallWindowProc(PrepareCode, 0, 0, 0, 0)
   FreeLibrary lb
End FunctionPrivate Function PrepareCode() As Long
    Dim lngX As Long, codeStart As Long
    ReDim mbytCode(18 + 32 + 6 * UBound(mlngParameters))
    codeStart = GetAlignedCodeStart(VarPtr(mbytCode(0)))
    mlngCP = codeStart - VarPtr(mbytCode(0))
    For lngX = 0 To mlngCP - 1
        mbytCode(lngX) = &HCC
    Next
    AddByteToCode &H58 'pop eax
    AddByteToCode &H59 'pop ecx
    AddByteToCode &H59 'pop ecx
    AddByteToCode &H59 'pop ecx
    AddByteToCode &H59 'pop ecx
    AddByteToCode &H50 'push eax
    For lngX = UBound(mlngParameters) To 1 Step -1
        AddByteToCode &H68 'push wwxxyyzz
        AddLongToCode mlngParameters(lngX)
    Next
    AddCallToCode mlngAddress
    AddByteToCode &HC3
    AddByteToCode &HCC
    PrepareCode = codeStart
End FunctionPrivate Sub AddCallToCode(lngAddress As Long)
    AddByteToCode &HE8
    AddLongToCode lngAddress - VarPtr(mbytCode(mlngCP)) - 4
End SubPrivate Sub AddLongToCode(lng As Long)
    Dim intX As Integer
    Dim byt(3) As Byte
    CopyMemory byt(0), lng, 4
    For intX = 0 To 3
        AddByteToCode byt(intX)
    Next
End SubPrivate Sub AddByteToCode(byt As Byte)
    mbytCode(mlngCP) = byt
    mlngCP = mlngCP + 1
End SubPrivate Function GetAlignedCodeStart(lngAddress As Long) As Long
    GetAlignedCodeStart = lngAddress + (15 - (lngAddress - 1) Mod 16)
    If (15 - (lngAddress - 1) Mod 16) = 0 Then GetAlignedCodeStart = GetAlignedCodeStart + 16
End Function
' 以下代碼放在 Form 裏，需一個 Command1 控件
Private Declare Function GetDC& Lib "user32" (ByVal hwnd As Long)
Private Declare Function ReleaseDC& Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long)Private Sub Command1_Click()
  Dim a As Long, b As Long
  Dim s() As Byte, x As Long, y As Long
  s = StrConv("Hello !", vbFromUnicode)
  b = 15
  x = CallApiByName("user32", "SetWindowTextA", hwnd, VarPtr(s(0)))
  Debug.Print "x= ", x
  x = CallApiByName("kernel32", "RtlMoveMemory", VarPtr(a), VarPtr(b), 4&)
  Debug.Print "a= ", a
  x = CallApiByName("user32", "FlashWindow", hwnd, 1&)
  Debug.Print "x= ", x
  dc1 = GetDC(hwnd)
  x = CallApiByName("user32", "GetDC", hwnd)
  Debug.Print "x= ", x, "dc= ", dc1
  x = ReleaseDC(hwnd, dc1)
End Sub

Answer 8

以前就听说有用CallWindowProc来调用自己代码的，但还真是没有见过，呵呵，开眼了
不过想想，按这样原理来的话，的确还有很多提供回调功能的API都可以拿来做这种事情哈