仿VB.NET,在VB6窗体模块中直接实现子类化的源码(Hassle原创)VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3090
ClientLeft = 60
ClientTop = 450
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3090
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox Text1
Height = 2415
Left = 120
TabIndex = 1
Text = "Text1"
Top = 480
Width = 4455
End
Begin VB.Label Label1
BorderStyle = 1 'Fixed Single
Caption = "Label1"
Height = 255
Left = 120
TabIndex = 0
Top = 120
Width = 4455
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' ******************************** Const ********************************Private Const GWL_WNDPROC = (-4)Private Const WM_MOUSEWHEEL = &H20APrivate Const THUNK_WNDPROC As String = "518D542400A100000000528B542418528B542418528B542418528B542418C7442410000000008B085250FF91000000008B44240059C21000"Private Const THUNK_SIGN As String = "8B442408C7000100000033C0C20800"
' ******************************** Type ********************************Private Type DWORD
LOWORD As Integer
HIWORD As Integer
End Type
' ******************************** Declare ********************************Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' ******************************** Variate ********************************Private m_aWndProc(0 To 55) As BytePrivate m_nPrevWndProc As LongPrivate m_hWndTarget As Long
' ******************************** Procedure ********************************Private Sub Form_Load()
Install Text1.hWnd, VarPtr(Form1)
End SubPrivate Function Sign() As Long
Sign = 0
End FunctionPrivate Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim dwW As DWORD, dwL As DWORD
Select Case uMsg
Case WM_MOUSEWHEEL
CopyMemory dwW, wParam, 4
CopyMemory dwL, lParam, 4
Label1.Caption = dwW.LOWORD & " " & dwW.HIWORD & " " & dwL.LOWORD & " " & dwL.HIWORD
End Select
WndProc = CallWindowProc(m_nPrevWndProc, hWnd, uMsg, wParam, lParam)
End FunctionPublic Sub Install(ByVal hWnd As Long, ByVal pObjVar As Long)
Dim i As Long
Dim aSign(0 To 14) As Byte
Dim pMe As Long
Dim Offset As Long
Dim pNew As Long
Dim pOld As Long
Dim nFind As Long
For i = 0 To UBound(aSign)
aSign(i) = Val("&H" & Mid(THUNK_SIGN, i * 2 + 1, 2))
Next
CopyMemory pMe, ByVal ObjPtr(Me), 4
Offset = &H1C
pNew = VarPtr(aSign(0))
Do
CopyMemory pOld, ByVal pMe + Offset, 4
If pOld = 0 Then Exit Do
CopyMemory ByVal pMe + Offset, pNew, 4
nFind = Sign()
CopyMemory ByVal pMe + Offset, pOld, 4
Offset = Offset + 4
If nFind = 1 Then
For i = 0 To UBound(m_aWndProc)
m_aWndProc(i) = Val("&H" & Mid(THUNK_WNDPROC, i * 2 + 1, 2))
Next
CopyMemory m_aWndProc(6), pObjVar, 4
CopyMemory m_aWndProc(44), Offset, 4
m_hWndTarget = hWnd
m_nPrevWndProc = SetWindowLong(m_hWndTarget, GWL_WNDPROC, VarPtr(m_aWndProc(0)))
Exit Do
End If
Loop
End SubPublic Sub Uninstall()
SetWindowLong m_hWndTarget, GWL_WNDPROC, m_nPrevWndProc
End Sub说明: 1. THUNK_WNDPROC相当于Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WndProc=Obj.WndProc(hWnd,uMsg,wParam,lParam)
End Function2. THUNK_SIGN相当于Private Function Sign() As Long
Sign = 1
End Function3. 注意:Private Function Sign() As Long
Sign = 0
End Function用于定位Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim dwW As DWORD, dwL As DWORD
Select Case uMsg
Case WM_MOUSEWHEEL
CopyMemory dwW, wParam, 4
CopyMemory dwL, lParam, 4
Label1.Caption = dwW.LOWORD & " " & dwW.HIWORD & " " & dwL.LOWORD & " " & dwL.HIWORD
End Select
WndProc = CallWindowProc(m_nPrevWndProc, hWnd, uMsg, wParam, lParam)
End Function两个函数必须是私有的, Sign与WndProc相邻,Sign在前面
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3090
ClientLeft = 60
ClientTop = 450
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3090
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox Text1
Height = 2415
Left = 120
TabIndex = 1
Text = "Text1"
Top = 480
Width = 4455
End
Begin VB.Label Label1
BorderStyle = 1 'Fixed Single
Caption = "Label1"
Height = 255
Left = 120
TabIndex = 0
Top = 120
Width = 4455
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' ******************************** Const ********************************Private Const GWL_WNDPROC = (-4)Private Const WM_MOUSEWHEEL = &H20APrivate Const THUNK_WNDPROC As String = "518D542400A100000000528B542418528B542418528B542418528B542418C7442410000000008B085250FF91000000008B44240059C21000"Private Const THUNK_SIGN As String = "8B442408C7000100000033C0C20800"
' ******************************** Type ********************************Private Type DWORD
LOWORD As Integer
HIWORD As Integer
End Type
' ******************************** Declare ********************************Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' ******************************** Variate ********************************Private m_aWndProc(0 To 55) As BytePrivate m_nPrevWndProc As LongPrivate m_hWndTarget As Long
' ******************************** Procedure ********************************Private Sub Form_Load()
Install Text1.hWnd, VarPtr(Form1)
End SubPrivate Function Sign() As Long
Sign = 0
End FunctionPrivate Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim dwW As DWORD, dwL As DWORD
Select Case uMsg
Case WM_MOUSEWHEEL
CopyMemory dwW, wParam, 4
CopyMemory dwL, lParam, 4
Label1.Caption = dwW.LOWORD & " " & dwW.HIWORD & " " & dwL.LOWORD & " " & dwL.HIWORD
End Select
WndProc = CallWindowProc(m_nPrevWndProc, hWnd, uMsg, wParam, lParam)
End FunctionPublic Sub Install(ByVal hWnd As Long, ByVal pObjVar As Long)
Dim i As Long
Dim aSign(0 To 14) As Byte
Dim pMe As Long
Dim Offset As Long
Dim pNew As Long
Dim pOld As Long
Dim nFind As Long
For i = 0 To UBound(aSign)
aSign(i) = Val("&H" & Mid(THUNK_SIGN, i * 2 + 1, 2))
Next
CopyMemory pMe, ByVal ObjPtr(Me), 4
Offset = &H1C
pNew = VarPtr(aSign(0))
Do
CopyMemory pOld, ByVal pMe + Offset, 4
If pOld = 0 Then Exit Do
CopyMemory ByVal pMe + Offset, pNew, 4
nFind = Sign()
CopyMemory ByVal pMe + Offset, pOld, 4
Offset = Offset + 4
If nFind = 1 Then
For i = 0 To UBound(m_aWndProc)
m_aWndProc(i) = Val("&H" & Mid(THUNK_WNDPROC, i * 2 + 1, 2))
Next
CopyMemory m_aWndProc(6), pObjVar, 4
CopyMemory m_aWndProc(44), Offset, 4
m_hWndTarget = hWnd
m_nPrevWndProc = SetWindowLong(m_hWndTarget, GWL_WNDPROC, VarPtr(m_aWndProc(0)))
Exit Do
End If
Loop
End SubPublic Sub Uninstall()
SetWindowLong m_hWndTarget, GWL_WNDPROC, m_nPrevWndProc
End Sub说明: 1. THUNK_WNDPROC相当于Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WndProc=Obj.WndProc(hWnd,uMsg,wParam,lParam)
End Function2. THUNK_SIGN相当于Private Function Sign() As Long
Sign = 1
End Function3. 注意:Private Function Sign() As Long
Sign = 0
End Function用于定位Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim dwW As DWORD, dwL As DWORD
Select Case uMsg
Case WM_MOUSEWHEEL
CopyMemory dwW, wParam, 4
CopyMemory dwL, lParam, 4
Label1.Caption = dwW.LOWORD & " " & dwW.HIWORD & " " & dwL.LOWORD & " " & dwL.HIWORD
End Select
WndProc = CallWindowProc(m_nPrevWndProc, hWnd, uMsg, wParam, lParam)
End Function两个函数必须是私有的, Sign与WndProc相邻,Sign在前面
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货