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

[supergreenbean]

以下是本人代码：
'----------------------- Form1.frm --------------------------------
'需要窗体上放一个名为Command1的按钮控件
Private m_lpVTable As Long
Private m_lpJmp As Long
Private lOldFunc As Long
Private lNewFunc As Long

Private 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 Sub

Private 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 Function

Public 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 Function

Public Sub TestSub()
MsgBox "我是快乐的Sub"
End Sub

Public 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;
}

[supergreenbean]

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

[supergreenbean]

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

[铁拳]

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

這段代碼跟學習 COM 有什麽聯系？

[铁拳]

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

幫忙測試一下。

[boyzhang]

GZ

[铁拳]

我這裏有一段調用 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 code

Public 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 Function

Private 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 Function

Private Sub AddCallToCode(lngAddress As Long)
AddByteToCode &HE8
AddLongToCode lngAddress - VarPtr(mbytCode(mlngCP)) - 4
End Sub

Private 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 Sub

Private Sub AddByteToCode(byt As Byte)
mbytCode(mlngCP) = byt
mlngCP = mlngCP + 1
End Sub

Private 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

[supergreenbean]

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

[hisofty]

up！看过这方面的东西，可惜不懂！

[supergreenbean]

'这是以二进制代码形式调用函数
'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 Sub

Public 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

[supergreenbean]

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