Lấy địa chỉ hàm thuộc ClassModule, Form, ... (In Object)

[Dark.Cosmos]

Tên chương trình: Function Pointer Maker (ActiveX Dll)
Phiên bản: 1.0.0
Tác giả: Dark.Cosmos
Chức năng: Lấy địa chỉ hàm nằm trong Object (ClassModule, Form, ...).

---

VB6 cung cấp hàm AddressOf để lấy địa chỉ hàm, nhưng chỉ lấy được địa chỉ của những hàm toàn cục thuộc standard module. Còn trong module class, form, ... thì không thể.
Thường thì ta sẽ dùng tới Virtual Function Table (VFT). Nhưng ở đây mình sử dụng phương pháp nhúng mã assembly để gọi gián tiếp hàm rtcCallByName trong Msvbvm60.
Zip đính kèm dưới đây gồm ActiveX DLL và project mẫu sử dụng Dll đó để tạo các callback function nằm ngay trong class module khi sử dụng hàm SetTimer (TimerProc), EnumWindows (EnumWindowsProc), SetWindowLong (WindowProc)

Mã: [Chọn tất cả] [Mở rộng/Thu hẹp]

1. Dim FPM As DCS_FuncPtrMaker.cD_FuncPointer
2. Set FPM = New DCS_FuncPtrMaker.cD_FuncPointer
3. Dim lpFuncPtr& lpFuncPtr = FPM.Make(Object, "Function_Name", 0)'Object / Function Name / Paramter Count / ...

GeSHi © Codebox Plus Extension

Class Timer:

Mã: [Chọn tất cả] [Mở rộng/Thu hẹp]

1. '=================================================================================================================================
2. '========== COM Function Pointer Maker ===========================================================================================
3. '========== Author Dark.Cosmos (DCS)  ===========================================================================================
4. '========== wwww.facebook.com/dark.cosmos.3102/ ==================================================================================
5. '=================================================================================================================================
6. '=================================================================================================================================
7. '==========[ TimerProc Example ]==================================================================================================
8. '=================================================================================================================================
9.  
10.  
11. Option Explicit
12. Private Const WM_TIMER = &H113&
13. Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
14. Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
15.  
16. Event TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
17. Private FP As cD_FuncPointer
18. Private lpTimerProc As Long
19. Private hTmr As Long, mHwnd As Long
20. Private bRaiseEvt As Boolean
21.  
22.  
23.  
24.  
25. '############################################################################################################################
26. Private Sub Class_Initialize()
27.     Set FP = New cD_FuncPointer
28. End Sub
29.  
30. Private Sub Class_Terminate()
31.     Call Delete
32.     Set FP = Nothing
33. End Sub
34.  
35. Function Create(Optional ByVal Interval& = 1000, Optional ByVal hWnd&, Optional ByVal idEvent&, Optional bRaiseEvent As Boolean) As Boolean
36.     If (hTmr <> 0 Or Interval < 0) Then Exit Function Else bRaiseEvt = bRaiseEvent
37.     If (lpTimerProc = 0) Then lpTimerProc = FP.Make(Me, "TimerProc", 4) If (lpTimerProc = 0) Then Exit Function
38.     hTmr = SetTimer(hWnd, idEvent, Interval, lpTimerProc) mHwnd = hWnd Create = (hTmr <> 0)
39. End Function
40.  
41. Function Delete() As Boolean
42.     If (hTmr <> 0) Then Delete = (KillTimer(mHwnd, hTmr) <> 0) hTmr = 0 mHwnd = 0
43.     If (lpTimerProc <> 0) Then Call FP.DeletePointer(lpTimerProc) lpTimerProc = 0
44. End Function
45.  
46. Function TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
47. On Error Resume Next If (uMsg <> WM_TIMER) Then Exit Function
48.     If (bRaiseEvt) Then RaiseEvent TimerProc(hWnd, uMsg, idEvent, dwTime)
49.     Call dBeepXP
50.     Debug.Print "In TimerProc " & CStr(timeGetTime)
51. End Function
52.  
53. Property Get IsRunning() As Boolean
54.     IsRunning = (lpTimerProc <> 0 And hTmr <> 0)
55. End Property

GeSHi © Codebox Plus Extension

Class EnumWindows:

Mã: [Chọn tất cả] [Mở rộng/Thu hẹp]

1. '=================================================================================================================================
2. '========== COM Function Pointer Maker ===========================================================================================
3. '========== Author Dark.Cosmos (DCS)  ===========================================================================================
4. '========== wwww.facebook.com/dark.cosmos.3102/ ==================================================================================
5. '=================================================================================================================================
6. '=================================================================================================================================
7. '==========[ EnumWindowsProc Example ]==================================================================================================
8. '=================================================================================================================================
9.  
10.  
11. Option Explicit
12. Private Declare Function EnumWindows Lib "user32" (ByVal lpEFunc As Long, ByVal lPrm As Long) As Long
13.  
14. Event OnNewHwnd(ByVal hWnd As Long)
15. Private FP As cD_FuncPointer
16. Private bRaiseEvt As Boolean
17.  
18.  
19.  
20.  
21. '############################################################################################################################
22. Private Sub Class_Initialize()
23.     Set FP = New cD_FuncPointer
24. End Sub
25.  
26. Private Sub Class_Terminate()
27.     Set FP = Nothing
28. End Sub
29.  
30.  
31. Function dEnum(Optional hWndRetList As Collection, Optional bRaiseEvent As Boolean) As Boolean
32. On Error Resume Next bRaiseEvt = bRaiseEvent
33.     If (hWndRetList Is Nothing) Then Set hWndRetList = New Collection
34.     Dim lpFunc& lpFunc = FP.Make(Me, "EnumWindowsProc", 2, vbLong, vbLong) If (lpFunc = 0) Then Exit Function
35.     Dim Ret& Ret = EnumWindows(lpFunc, ByVal ObjPtr(hWndRetList))
36.     dEnum = (Ret = -1) 'Do not code here, because out of obj stream.
37. End Function
38.  
39. Function EnumWindowsProc(ByVal hWnd As Long, ByVal lPrm As Long) As Long
40. On Error Resume Next
41.     Dim hList As Collection If (Not FP.ObjFromPtr(hList, lPrm)) Then Exit Function
42.     Call hList.Add(hWnd) If (bRaiseEvt) Then RaiseEvent OnNewHwnd(hWnd)
43.     EnumWindowsProc = -1 'return true to continue
44. End Function

GeSHi © Codebox Plus Extension

Class SubClass:

Mã: [Chọn tất cả] [Mở rộng/Thu hẹp]

1. '=================================================================================================================================
2. '========== COM Function Pointer Maker ===========================================================================================
3. '========== Author Dark.Cosmos (DCS)  ===========================================================================================
4. '========== wwww.facebook.com/dark.cosmos.3102/ ==================================================================================
5. '=================================================================================================================================
6. '=================================================================================================================================
7. '==========[ WindowsProc Example ]==================================================================================================
8. '=================================================================================================================================
9.  
10.  
11. Option Explicit
12. Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
13. Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPtr As Long, ByVal P1 As Long, ByVal P2 As Long, ByVal P3 As Long, ByVal P4 As Long) As Long
14.  
15. Event WndProcEvent(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
16. Private FP As cD_FuncPointer
17. Private lpOldFunc As Long, mHwnd As Long
18. Private bRaiseEvt As Boolean
19.  
20.  
21.  
22.  
23. '############################################################################################################################
24. Private Sub Class_Initialize()
25.     Set FP = New cD_FuncPointer
26. End Sub
27.  
28. Private Sub Class_Terminate()
29.     Set FP = Nothing
30. End Sub
31.  
32. Function Subclass(ByVal hWnd&, Optional bRaiseEvent As Boolean) As Boolean
33.     If (lpOldFunc <> 0 Or hWnd = 0) Then Exit Function Else mHwnd = hWnd bRaiseEvt = bRaiseEvent
34.     Dim lpFunc& lpFunc = FP.Make(Me, "WindowProc", 4) If (lpFunc = 0) Then Exit Function
35.     lpOldFunc = SetWindowLongA(hWnd, -4, lpFunc) Subclass = (lpOldFunc > 0)
36. End Function
37.  
38. Sub UnSubclass()
39.     If (lpOldFunc <> 0 Or mHwnd <> 0) Then Call SetWindowLongA(mHwnd, -4, lpOldFunc) lpOldFunc = 0 mHwnd = 0
40. End Sub
41.  
42. Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
43. On Error Resume Next
44.     'Your code here
45.    Select Case uMsg
46.         Case &H100, &H101 If (bRaiseEvt) Then RaiseEvent WndProcEvent(hWnd, uMsg, wParam, lParam)
47.         Case &H201, &H202 If (bRaiseEvt) Then RaiseEvent WndProcEvent(hWnd, uMsg, wParam, lParam)
48.         Case &H204, &H205 If (bRaiseEvt) Then RaiseEvent WndProcEvent(hWnd, uMsg, wParam, lParam)
49.     End Select
50.     WindowProc = CallWindowProcA(lpOldFunc, hWnd, uMsg, wParam, lParam)
51. End Function

GeSHi © Codebox Plus Extension

FunctionPointerMaker.zip

(64.69 KiB) Đã tải về 418 lần