仿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在前面