• Vui lòng đọc nội qui diễn đàn để tránh bị xóa bài viết
  • Tìm kiếm trước khi đặt câu hỏi

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

Các Module, Class, UserControl và thư viện OCX, DLL hỗ trợ cho Visual Basic
Dark.Cosmos
Thành viên năng nổ
Thành viên năng nổ
Posts: 72
Joined: Fri 21/11/2014 3:58 am
Has thanked: 25 times
Been thanked: 14 times
Contact:

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

Postby Dark.Cosmos » Thu 17/12/2015 7:57 am

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:
[vb]'=================================================================================================================================
'========== 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[/vb]

Class EnumWindows:
[vb]'=================================================================================================================================
'========== 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[/vb]

Class SubClass:
[vb]'=================================================================================================================================
'========== 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[/vb]

FunctionPointerMaker.zip
(64.69 KiB) Downloaded 309 times


Pic.png



Return to “[VB] Module, Class, UserControl, OCX”

Who is online

Users browsing this forum: No registered users and 0 guests