Trang 1 trên 1

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

Đã gửi: T.Năm 17/12/2015 7:57 am
gửi bởi 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)

  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 / ...


Class Timer:
  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


Class EnumWindows:
  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


Class SubClass:
  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


FunctionPointerMaker.zip
(64.69 KiB) Đã tải 146 lần


Pic.png