【仅32位】【另类函数指针】函数获取自身所在模块和函数名

loquat

老外很厉害，多年前我就想要的东西，有了VB6版本

顺势迁移了一个VBA 32位版本，用到的技术如下：
1、函数指针，本方法仅用于32位，64位需要用其他方法
2、内存查找未导出函数

声明：
1、目前应该能用于VBA6和VBA7，如果你的32位Office不能用，请上传相应VBE6.dll或VBE7.dll
2、仅提供一种新玩法，不保证所有人电脑都能用，水平有限，也不一定能给所有人解决问题
3、欢迎上传移植成功的64位版本

代码如下：
'mCallingProcName.bas

1. Option Explicit
   
2. Option Base 0
   
3. 
   
4. Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
   
5. Private Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (dst As Any, src As Any, ByVal Length As Long)
   
6. '函数原型
   
7. Private Function EbSetMode(ByVal Addr As Long, ByVal Mode As Long) As Long
   
8. End Function
   
9. Private Function EbGetCallstackCount(ByVal Addr As Long, ByRef lCount As Long) As Long
   
10. End Function
    
11. Private Function EbGetCallstackFunction(ByVal Addr As Long, _
    
12.                          ByVal lIndex As Long, _
    
13.                          ByVal pProject As Long, _
    
14.                          ByVal pModule As Long, _
    
15.                          ByVal pFunction As Long, _
    
16.                          ByRef lRet As Long) As Long
    
17. End Function
    
18. 
    
19. Sub Test()
    
20.     MsgBox GetCallingProcName()
    
21.     End
    
22. End Sub
    
23. 
    
24. Public Function GetCallingProcName(Optional ByVal lReserved As Long) As String
    
25.     Dim lStackCount As Long
    
26.     Dim sProject As String
    
27.     Dim sModule As String
    
28.     Dim sFunction As String
    
29.     Dim hEbSetMode As Long
    
30.     Dim hEbGetCallstackCount As Long
    
31.     Dim hEbGetCallstackFunction As Long
    
32.     Dim hVbe            As Long
    
33.     Dim pSection        As Long
    
34.     Dim pStartScan      As Long
    
35.     Dim pEndScan        As Long
    
36.     Dim e_lfanew        As Long
    
37.     Dim iNumOfSec       As Integer
    
38.     Dim iOptSize        As Integer
    
39.     Dim lIndex          As Long
    
40.     Dim cName           As Currency
    
41. #If VBA7 Then
    
42.     hVbe = GetModuleHandle(StrPtr("VBE7"))
    
43. #ElseIf VBA6 Then
    
44.     hVbe = GetModuleHandle(StrPtr("VBE6"))
    
45. #End If
    
46.     If hVbe = 0 Then Exit Function
    
47. #If VBA6 Or VBA7 Then
    
48.     memcpy e_lfanew, ByVal hVbe + &H3C, 4
    
49.     memcpy iNumOfSec, ByVal hVbe + e_lfanew + 6, 2
    
50.     memcpy iOptSize, ByVal hVbe + e_lfanew + &H14, 2
    
51.     pSection = hVbe + e_lfanew + &H18 + iOptSize
    
52.     For lIndex = 0 To iNumOfSec - 1
    
53.         memcpy cName, ByVal pSection, 8
    
54.         If cName = 50023612.1134@ Then
    
55.             memcpy pStartScan, ByVal pSection + &HC, 4
    
56.             memcpy pEndScan, ByVal pSection + &H8, 4
    
57.             pStartScan = pStartScan + hVbe
    
58.             pEndScan = pEndScan + pStartScan - 1
    
59.             Exit For
    
60.         End If
    
61.         pSection = pSection + &H28
    
62.     Next
    
63.     If pStartScan = 0 Or pEndScan = 0 Then Exit Function
    
64. #End If
    
65.    
    
66. #If VBA7 Then
    
67.     hEbSetMode = SearchFunction(pStartScan, pEndScan, "8B FF 53 55 56 57 E8 XX XX XX XX 8B 3D XX XX XX XX 8B F0 33 ED 8B DD 83 XX 01 75 0C E8 XX XX XX XX 85 C0 74 XX 6A 02 5E", 0)
    
68.     hEbGetCallstackCount = SearchFunction(pStartScan, pEndScan, "E8 XX XX XX XX 83 E8 00 74 XX 48 74 XX 48 75 XX A1 XX XX XX XX 8B 4C 24 04 83 21 00 05 XX XX XX XX 74 XX FF 01 8B 00 85 C0 75 XX EB XX", 0)
    
69.     hEbGetCallstackFunction = SearchFunction(pStartScan, pEndScan, "81 EC XX XX XX XX A1 XX XX XX XX 33 C4 89 XX XX XX 8B 84 XX XX XX 00 00 53 8B XX XX XX XX 00 00 55 33 ED 56 89 XX XX XX 8B 84 XX XX XX 00 00 57 8B XX XX XX XX 00 00 89 44", 0)
    
70. #ElseIf VBA6 Then
    
71.     hEbSetMode = SearchFunction(pStartScan, pEndScan, "55 8B EC 51 56 57 E8 XX XX XX XX XX XX XX XX 8B 35 XX XX XX XX 8B F8 83 XX 01 75 0C E8 XX XX XX XX 85 C0 74 XX 6A 02 5F", 0)
    
72.     hEbGetCallstackCount = SearchFunction(pStartScan, pEndScan, "E8 XX XX XX XX 83 E8 00 74 XX 48 74 XX 48 75 XX A1 XX XX XX XX 8B 4C 24 04 05 XX XX XX XX 83 21 00 EB XX FF 01 8B 00 85 C0 7C XX EB XX", 0)
    
73.     hEbGetCallstackFunction = SearchFunction(pStartScan, pEndScan, "55 8B EC 81 EC XX XX XX XX A1 XX XX XX XX 33 C5 89 XX XX 8B XX XX 53 8B XX XX 89 XX XX 8B XX XX 56 33 F6 89 XX XX 8B XX XX 57 89 XX XX 8B XX XX 33 FF 89 XX XX 89 XX XX 89", 0)
    
74. #End If
    
75. 
    
76.     PatchFunc AddressOf EbSetMode
    
77.     PatchFunc AddressOf EbGetCallstackCount
    
78.     PatchFunc AddressOf EbGetCallstackFunction
    
79.    
    
80.     EbSetMode hEbSetMode, 2
    
81.     If EbGetCallstackCount(hEbGetCallstackCount, lStackCount) >= 0 Then
    
82.         If lStackCount > 1 Then
    
83.             If EbGetCallstackFunction(hEbGetCallstackFunction, 1, VarPtr(sProject), VarPtr(sModule), VarPtr(sFunction), 0) >= 0 Then
    
84.                 GetCallingProcName = sModule & "::" & sFunction
    
85.             End If
    
86.         End If
    
87.     End If
    
88.     EbSetMode hEbSetMode, 1
    
89. End Function
    
90. 
    
91. Private Sub PatchFunc(ByVal Addr As Long)
    
92.     memcpy Addr, ByVal Addr + &H16, 4
    
93.     memcpy ByVal Addr, &HFF505958, 4
    
94.     memcpy ByVal Addr + 4, &HE1, 4
    
95. End Sub
    

复制代码

'mSearchFunc.bas

1. Option Explicit
   
2. Option Base 0
   
3. 
   
4. Private Const FADF_AUTO As Long = 1
   
5. 
   
6. Private Type SAFEARRAYBOUND
   
7.     cElements As Long
   
8.     lLbound As Long
   
9. End Type
   
10. 
    
11. Private Type SAFEARRAY
    
12.     cDims As Integer
    
13.     fFeatures As Integer
    
14.     cbElements As Long
    
15.     cLocks As Long
    
16.     pvData As Long
    
17.     Bounds As SAFEARRAYBOUND
    
18. End Type
    
19. 
    
20. Private Declare Sub DupArray Lib "kernel32" _
    
21.             Alias "RtlMoveMemory" ( _
    
22.             ByRef Destination() As Any, _
    
23.             ByRef pSA As Any, _
    
24.             Optional ByVal Length As Long = 4)
    
25. 
    
26. Public Function SearchFunction(ByVal pStartScan As Long, ByVal pEndScan As Long, ByVal strHex As String, Optional ByVal offset As Long = 0) As Long
    
27.     Dim bData() As Byte
    
28.     Dim tSAMap As SAFEARRAY
    
29.     Dim lIndex As Long
    
30. 
    
31.     tSAMap.cbElements = 1
    
32.     tSAMap.cDims = 1
    
33.     tSAMap.fFeatures = FADF_AUTO
    
34.     tSAMap.Bounds.cElements = CLng(pEndScan - pStartScan) + 1
    
35.     tSAMap.pvData = pStartScan
    
36.     DupArray bData, VarPtr(tSAMap)
    
37. 
    
38.     Dim bTemplate() As Byte
    
39.     Dim bMask() As Byte
    
40. 
    
41.     Dim arrTemp
    
42.     Dim i As Long
    
43.     arrTemp = Split(strHex)
    
44. 
    
45.     ReDim bTemplate(UBound(arrTemp) - LBound(arrTemp)) As Byte
    
46.     ReDim bMask(UBound(arrTemp) - LBound(arrTemp)) As Byte
    
47. 
    
48.     For i = LBound(arrTemp) To UBound(arrTemp)
    
49.         If arrTemp(i) <> "XX" Then
    
50.             bMask(i) = 1
    
51.             bTemplate(i) = Val("&H" & arrTemp(i))
    
52.         End If
    
53.     Next i
    
54. 
    
55.     lIndex = FindSignature(bData(), bTemplate(), bMask())
    
56.     DupArray bData, 0@
    
57.     If lIndex = -1 Then Exit Function
    
58.     SearchFunction = pStartScan + lIndex + offset
    
59. End Function
    
60. 
    
61. Public Function FindSignature(ByRef bData() As Byte, ByRef bSignature() As Byte, ByRef bMask() As Byte) As Long
    
62.     Dim lDataIndex As Long
    
63.     Dim lSignIndex As Long
    
64.     lDataIndex = 0: lSignIndex = 0
    
65.     Do While lDataIndex <= UBound(bData)
    
66.         If bData(lDataIndex) = bSignature(lSignIndex) Or bMask(lSignIndex) = 0 Then
    
67.             lSignIndex = lSignIndex + 1
    
68.             If lSignIndex > UBound(bSignature) Then               '
    
69.                 FindSignature = lDataIndex - UBound(bSignature)
    
70.                 Exit Function
    
71.             End If
    
72.         Else
    
73.             If lSignIndex Then
    
74.                 lDataIndex = lDataIndex - lSignIndex + 1
    
75.                 lSignIndex = 0
    
76.             End If
    
77.         End If
    
78.         lDataIndex = lDataIndex + 1
    
79.     Loop
    
80.     FindSignature = -1
    
81. End Function
    

复制代码

loquat

使用案例：
Sub Test()
    On Error GoTo ErrH
1   Dim a As Long
2   a = 1 / 0
    GoTo lExit:
ErrH:
    MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & Erl() & vbCrLf & GetCallingProcName()  '这里还可以写日志
    Resume Next
lExit:
End Sub

桑特容易额

好东西啊 支持64位就好了

loquat

目前来看vba 64应该有难度，总是把堆栈干爆
猜测是不是64位的这几个api有外部依赖。