VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
123
返回列表 发新帖
楼主: iceboy

[原创] 【暑假礼物】挂钩实现通过API名字空间调用任意函数

[复制链接]
发表于 2012-8-13 19:50:58 | 显示全部楼层
我这下理解了。这个DllFuncitonCall,只在该函数第一次调用时调用。后面就不调用了。这么看来,VB的API调用效率还是可以的。不是每一次都被这么过滤一次的。
回复 支持 反对

使用道具 举报

发表于 2012-8-13 20:01:25 | 显示全部楼层
  1. Option Explicit

  2. Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
  3.     ByVal ModuleName As String) As Long

  4. Private Declare Function GetProcAddress Lib "kernel32" ( _
  5.     ByVal ModuleHandle As Long, _
  6.     ByVal ProcName As String) As Long

  7. Private Declare Function VirtualProtect Lib "kernel32" ( _
  8.     ByVal lpAddress As Long, _
  9.     ByVal dwSize As Long, _
  10.     ByVal flNewProcect As Long, _
  11.     flOldProtect As Long) As Long

  12. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  13.     Destination As Any, _
  14.     Source As Any, _
  15.     ByVal length As Long)

  16. Private Declare Function MultiByteToWideChar Lib "kernel32" ( _
  17.     ByVal CodePage As Long, _
  18.     ByVal dwFlags As Long, _
  19.     ByVal lpMultiByteStr As Long, _
  20.     ByVal cchMultiByte As Long, _
  21.     ByVal lpWideCharStr As Long, _
  22.     ByVal cchWideChar As Long) As Long

  23. Private Declare Function DllFunctionCall Lib "msvbvm60" ( _
  24.     ByVal lpDescriptor As Long) As Long

  25. Private Declare Function DllFunctionCall2 Lib "vba6" Alias "DllFunctionCall" ( _
  26.     ByVal lpDescriptor As Long) As Long

  27. Private Declare Sub PutMem4 Lib "msvbvm60" ( _
  28.     ByVal Ptr As Long, _
  29.     ByVal NewVal As Long)

  30. Private Const CP_ACP = 0
  31. Private Const PAGE_EXECUTE_READWRITE = &H40

  32. Private Type DllFunctionContext
  33.   Unknown                   As Long
  34.   ModuleHandle              As Long
  35.   FunctionPtr               As Long
  36. End Type

  37. Private Type DllFunctionDescriptor
  38.   ModuleNamePtr             As Long
  39.   FunctionNamePtr           As Long
  40.   Unknown                   As Long
  41.   ContextPtr                As Long
  42. End Type

  43. Private Type dymFunctionType
  44.   Key                       As String
  45.   Ptr                       As Long
  46.   VarPtrOfContextPtr        As Long
  47. End Type

  48. Private Type dymFunctionsType
  49.   Items()                   As dymFunctionType
  50.   Count                     As Long
  51. End Type

  52. Private Type dymVariablesType
  53.   FunctionMap               As dymFunctionsType

  54.   InIDE                     As Boolean
  55.   HookInitialized           As Boolean
  56.   pfnDllFunctionCall        As Long
  57.   OriginalCode(0 To 1)      As Long
  58.   HookedCode(0 To 1)        As Long
  59. End Type
  60. Private m                   As dymVariablesType

  61. Private Function pIndexOfFunc(ByVal sKey As String) As Long
  62.   Dim lngI       As Long

  63.   pIndexOfFunc = -1
  64.   For lngI = 0 To m.FunctionMap.Count - 1
  65.     If VBA.StrComp(m.FunctionMap.Items(lngI).Key, sKey, vbBinaryCompare) = 0 Then
  66.       pIndexOfFunc = lngI
  67.       Exit Function
  68.     End If
  69.   Next
  70. End Function

  71. Private Function pSetIDE() As Boolean
  72.   m.InIDE = True
  73.   pSetIDE = True
  74. End Function

  75. Private Function GetStringByPtr(ByVal Ptr As Long) As String
  76.   Dim lLen      As Long

  77.   lLen = MultiByteToWideChar(CP_ACP, 0, Ptr, -1, 0, 0)
  78.   GetStringByPtr = Space(lLen - 1)
  79.   Call MultiByteToWideChar(CP_ACP, 0, Ptr, -1, StrPtr(GetStringByPtr), lLen)
  80.   GetStringByPtr = GetStringByPtr
  81. End Function

  82. Private Function MyDllFunctionCall(ByRef dfd As DllFunctionDescriptor) As Long
  83.   Dim sMoudle         As String
  84.   Dim sFunc           As String
  85.   Dim lIndex          As Long

  86.   Call UnHook

  87.   sMoudle = GetStringByPtr(dfd.ModuleNamePtr)
  88.   sFunc = GetStringByPtr(dfd.FunctionNamePtr)

  89.   lIndex = pIndexOfFunc(VBA.LCase(sMoudle & "." & sFunc))
  90.   If lIndex = -1 Then GoTo NotFound
  91.   
  92.   m.FunctionMap.Items(lIndex).VarPtrOfContextPtr = dfd.ContextPtr + 8
  93.     '//获得地址

  94.   Call PutMem4(dfd.ContextPtr + 8, m.FunctionMap.Items(lIndex).Ptr)
  95.   MyDllFunctionCall = m.FunctionMap.Items(lIndex).Ptr
  96.   Call Hook
  97.   Exit Function
  98. NotFound:
  99.   If m.InIDE Then
  100.     MyDllFunctionCall = DllFunctionCall2(VarPtr(dfd))
  101.   Else
  102.     MyDllFunctionCall = DllFunctionCall(VarPtr(dfd))
  103.   End If
  104.   Call Hook
  105. End Function

  106. Public Sub Hook()
  107.   Dim hMod            As Long
  108.   Dim flOldProtect    As Long

  109.   If Not m.HookInitialized Then
  110.     Debug.Assert pSetIDE

  111.     If m.InIDE Then
  112.       hMod = GetModuleHandle("vba6")
  113.     Else
  114.       hMod = GetModuleHandle("msvbvm60")
  115.     End If
  116.     m.pfnDllFunctionCall = GetProcAddress(hMod, "DllFunctionCall")
  117.     Call CopyMemory(m.OriginalCode(0), ByVal m.pfnDllFunctionCall, 8)
  118.     m.HookedCode(0) = &HCCCCC0C7: m.HookedCode(1) = &HE0FFFFFF
  119.     Call PutMem4(VarPtr(m.HookedCode(0)) + 2, AddressOf MyDllFunctionCall)
  120.     m.HookInitialized = True
  121.   End If

  122.   Call VirtualProtect(m.pfnDllFunctionCall, 8, PAGE_EXECUTE_READWRITE, flOldProtect)
  123.   Call CopyMemory(ByVal m.pfnDllFunctionCall, m.HookedCode(0), 8)
  124.   Call VirtualProtect(m.pfnDllFunctionCall, 8, flOldProtect, flOldProtect)
  125. End Sub

  126. Public Sub UnHook()
  127.   Dim flOldProtect    As Long

  128.   If m.HookInitialized Then
  129.     Call VirtualProtect(m.pfnDllFunctionCall, 8, PAGE_EXECUTE_READWRITE, flOldProtect)
  130.     Call CopyMemory(ByVal m.pfnDllFunctionCall, m.OriginalCode(0), 8)
  131.     Call VirtualProtect(m.pfnDllFunctionCall, 8, flOldProtect, flOldProtect)
  132.   End If
  133. End Sub

  134. Public Sub SetProcAddress(ByVal sModule As String, ByVal sFunc As String, ByVal pFunc As Long)
  135.   Dim lIndex        As Long
  136.   
  137.   lIndex = pIndexOfFunc(VBA.LCase(sModule & "." & sFunc))
  138.   If lIndex = -1 Then
  139.     Dim sKey         As String
  140.   
  141.     sKey = VBA.LCase(sModule & "." & sFunc)
  142.     ReDim Preserve m.FunctionMap.Items(m.FunctionMap.Count)
  143.     With m.FunctionMap.Items(m.FunctionMap.Count)
  144.       .Key = sKey
  145.       .Ptr = pFunc
  146.     End With
  147.     m.FunctionMap.Count = m.FunctionMap.Count + 1
  148.       '//追加
  149.   
  150.   Else
  151.     m.FunctionMap.Items(lIndex).Ptr = pFunc
  152.     Call PutMem4(m.FunctionMap.Items(lIndex).VarPtrOfContextPtr, pFunc)
  153.   End If
  154. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2012-8-13 20:02:59 | 显示全部楼层
调用
  1. Option Explicit

  2. Declare Function MyApiFunction Lib "mydll" () As Long
  3. Declare Function MyApiFunction2 Lib "mydll" () As Long
  4. Declare Function MyApiFunction3 Lib "mydll" () As Long

  5. Function MyApiFunctionImpl() As Long
  6.     MyApiFunctionImpl = 70514
  7. End Function

  8. Function MyApiFunctionImpl2() As Long
  9.     MyApiFunctionImpl2 = MyApiFunction3 + 2
  10. End Function

  11. Sub Main()
  12.     Call SetProcAddress("mydll", "MyApiFunction", AddressOf MyApiFunctionImpl)
  13.     Call SetProcAddress("mydll", "MyApiFunction2", AddressOf MyApiFunctionImpl)
  14.     Call SetProcAddress("mydll", "MyApiFunction3", AddressOf MyApiFunctionImpl)
  15.     Call Hook
  16.     MsgBox CStr(MyApiFunction())
  17.     MsgBox CStr(MyApiFunction2())
  18.     MsgBox CStr(MyApiFunction())
  19.     Call SetProcAddress("mydll", "MyApiFunction2", AddressOf MyApiFunctionImpl2)
  20.     MsgBox CStr(MyApiFunction2())
  21.     Call UnHook
  22. '    MsgBox CStr(MyApiFunction3())
  23. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2012-8-13 20:04:27 | 显示全部楼层
代码中。把 Register改为 SetProcAddress
把EnableHook改为 Hook
DisableHook改为 UnHook
FunctionMap,改为用数组存储。
回复 支持 反对

使用道具 举报

发表于 2012-8-17 21:28:00 | 显示全部楼层
我在我的工程里用了下。效果的确不错。
用的前提是,你对你要调用的函数的参数类型和返回值类型非常了解。
如果是字符串类型,建议不要使用,会出现莫名错误。
如果是结构类型,子级成员或是其下属的成员,不管有多少层,只要含有字符串型变量。都会有问题。
建议字符串可以使用Long型来记录。
具体代码如下:
  1. '//GetString
  2. Public Function GetString(ByRef s As Long) As String
  3.     Dim sTmp           As String

  4.     Call CopyMemory(ByVal VarPtr(sTmp), ByVal VarPtr(s), 4)
  5.       '//获得引用

  6.     GetString = sTmp
  7.       '//赋值,这样将重新分配空间

  8.     Call CopyMemory(ByVal VarPtr(sTmp), CLng(0), 4)
  9.       '//清空引用
  10. End Function

  11. '//SetString
  12. Public Sub SetString2(ByRef s As Long, ByRef NewVal As String)
  13.     Dim sTmp           As String

  14.     sTmp = NewVal
  15.    
  16.     s = StrPtr(sTmp)

  17.     Call CopyMemory(ByVal VarPtr(sTmp), CLng(0), 4)
  18.       '//清空引用

  19. End Sub

  20. '例子
  21. Dim s      As  Long

  22. Call SetString(s,"Abc")
  23. Debug.print GetString(s)
复制代码

点评

字符串类型的问题是,API Declare会被转成ANSI,而VB函数要求BSTR(Unicode+长度前缀);API声明为Long,传参用StrPtr,VB函数声明为String理论上可行。  发表于 2013-1-10 12:14
回复 支持 反对

使用道具 举报

发表于 2012-9-27 17:09:19 | 显示全部楼层
好东西,先收藏着,免了到时候找不着
回复 支持 反对

使用道具 举报

发表于 2012-10-14 16:35:41 | 显示全部楼层
我表示完全被征服了!
回复 支持 反对

使用道具 举报

发表于 2012-10-20 11:01:22 | 显示全部楼层

我得有多长时间没回来了
想想过去真怀念啊
回复 支持 反对

使用道具 举报

发表于 2013-1-9 13:30:10 | 显示全部楼层
顶顶顶顶顶顶
回复 支持 反对

使用道具 举报

头像被屏蔽
发表于 2013-3-12 07:51:47 | 显示全部楼层
先看文章,写得直好;再看作者,原来你也是个大牛,ICEBOY,讲解精辟!!!!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2022-9-26 09:02

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表