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)
- Dim FPM As DCS_FuncPtrMaker.cD_FuncPointer
- Set FPM = New DCS_FuncPtrMaker.cD_FuncPointer
- Dim lpFuncPtr& lpFuncPtr = FPM.Make(Object, "Function_Name", 0)'Object / Function Name / Paramter Count / ...
Class Timer:
- '=================================================================================================================================
- '========== COM Function Pointer Maker ===========================================================================================
- '========== Author Dark.Cosmos (DCS) ===========================================================================================
- '========== wwww.facebook.com/dark.cosmos.3102/ ==================================================================================
- '=================================================================================================================================
- '=================================================================================================================================
- '==========[ TimerProc Example ]==================================================================================================
- '=================================================================================================================================
- Option Explicit
- Private Const WM_TIMER = &H113&
- Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
- Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
- Event TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
- Private FP As cD_FuncPointer
- Private lpTimerProc As Long
- Private hTmr As Long, mHwnd As Long
- Private bRaiseEvt As Boolean
- '############################################################################################################################
- Private Sub Class_Initialize()
- Set FP = New cD_FuncPointer
- End Sub
- Private Sub Class_Terminate()
- Call Delete
- Set FP = Nothing
- End Sub
- Function Create(Optional ByVal Interval& = 1000, Optional ByVal hWnd&, Optional ByVal idEvent&, Optional bRaiseEvent As Boolean) As Boolean
- If (hTmr <> 0 Or Interval < 0) Then Exit Function Else bRaiseEvt = bRaiseEvent
- If (lpTimerProc = 0) Then lpTimerProc = FP.Make(Me, "TimerProc", 4) If (lpTimerProc = 0) Then Exit Function
- hTmr = SetTimer(hWnd, idEvent, Interval, lpTimerProc) mHwnd = hWnd Create = (hTmr <> 0)
- End Function
- Function Delete() As Boolean
- If (hTmr <> 0) Then Delete = (KillTimer(mHwnd, hTmr) <> 0) hTmr = 0 mHwnd = 0
- If (lpTimerProc <> 0) Then Call FP.DeletePointer(lpTimerProc) lpTimerProc = 0
- End Function
- Function TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
- On Error Resume Next If (uMsg <> WM_TIMER) Then Exit Function
- If (bRaiseEvt) Then RaiseEvent TimerProc(hWnd, uMsg, idEvent, dwTime)
- Call dBeepXP
- Debug.Print "In TimerProc " & CStr(timeGetTime)
- End Function
- Property Get IsRunning() As Boolean
- IsRunning = (lpTimerProc <> 0 And hTmr <> 0)
- End Property
Class EnumWindows:
- '=================================================================================================================================
- '========== COM Function Pointer Maker ===========================================================================================
- '========== Author Dark.Cosmos (DCS) ===========================================================================================
- '========== wwww.facebook.com/dark.cosmos.3102/ ==================================================================================
- '=================================================================================================================================
- '=================================================================================================================================
- '==========[ EnumWindowsProc Example ]==================================================================================================
- '=================================================================================================================================
- Option Explicit
- Private Declare Function EnumWindows Lib "user32" (ByVal lpEFunc As Long, ByVal lPrm As Long) As Long
- Event OnNewHwnd(ByVal hWnd As Long)
- Private FP As cD_FuncPointer
- Private bRaiseEvt As Boolean
- '############################################################################################################################
- Private Sub Class_Initialize()
- Set FP = New cD_FuncPointer
- End Sub
- Private Sub Class_Terminate()
- Set FP = Nothing
- End Sub
- Function dEnum(Optional hWndRetList As Collection, Optional bRaiseEvent As Boolean) As Boolean
- On Error Resume Next bRaiseEvt = bRaiseEvent
- If (hWndRetList Is Nothing) Then Set hWndRetList = New Collection
- Dim lpFunc& lpFunc = FP.Make(Me, "EnumWindowsProc", 2, vbLong, vbLong) If (lpFunc = 0) Then Exit Function
- Dim Ret& Ret = EnumWindows(lpFunc, ByVal ObjPtr(hWndRetList))
- dEnum = (Ret = -1) 'Do not code here, because out of obj stream.
- End Function
- Function EnumWindowsProc(ByVal hWnd As Long, ByVal lPrm As Long) As Long
- On Error Resume Next
- Dim hList As Collection If (Not FP.ObjFromPtr(hList, lPrm)) Then Exit Function
- Call hList.Add(hWnd) If (bRaiseEvt) Then RaiseEvent OnNewHwnd(hWnd)
- EnumWindowsProc = -1 'return true to continue
- End Function
Class SubClass:
- '=================================================================================================================================
- '========== COM Function Pointer Maker ===========================================================================================
- '========== Author Dark.Cosmos (DCS) ===========================================================================================
- '========== wwww.facebook.com/dark.cosmos.3102/ ==================================================================================
- '=================================================================================================================================
- '=================================================================================================================================
- '==========[ WindowsProc Example ]==================================================================================================
- '=================================================================================================================================
- Option Explicit
- Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
- 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
- Event WndProcEvent(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
- Private FP As cD_FuncPointer
- Private lpOldFunc As Long, mHwnd As Long
- Private bRaiseEvt As Boolean
- '############################################################################################################################
- Private Sub Class_Initialize()
- Set FP = New cD_FuncPointer
- End Sub
- Private Sub Class_Terminate()
- Set FP = Nothing
- End Sub
- Function Subclass(ByVal hWnd&, Optional bRaiseEvent As Boolean) As Boolean
- If (lpOldFunc <> 0 Or hWnd = 0) Then Exit Function Else mHwnd = hWnd bRaiseEvt = bRaiseEvent
- Dim lpFunc& lpFunc = FP.Make(Me, "WindowProc", 4) If (lpFunc = 0) Then Exit Function
- lpOldFunc = SetWindowLongA(hWnd, -4, lpFunc) Subclass = (lpOldFunc > 0)
- End Function
- Sub UnSubclass()
- If (lpOldFunc <> 0 Or mHwnd <> 0) Then Call SetWindowLongA(mHwnd, -4, lpOldFunc) lpOldFunc = 0 mHwnd = 0
- End Sub
- Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
- On Error Resume Next
- 'Your code here
- Select Case uMsg
- Case &H100, &H101 If (bRaiseEvt) Then RaiseEvent WndProcEvent(hWnd, uMsg, wParam, lParam)
- Case &H201, &H202 If (bRaiseEvt) Then RaiseEvent WndProcEvent(hWnd, uMsg, wParam, lParam)
- Case &H204, &H205 If (bRaiseEvt) Then RaiseEvent WndProcEvent(hWnd, uMsg, wParam, lParam)
- End Select
- WindowProc = CallWindowProcA(lpOldFunc, hWnd, uMsg, wParam, lParam)
- End Function