subclassgrid.cls

这是一个很好的VB控件,你下载之后就会发现它的神秘之处

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "SubClassGrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Implements ISubclass
Private m_Hwnd As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Const WM_MOUSEWHEEL = &H20A
Event MouseWheel(ByVal Rotation As Long, ByVal X As Long, ByVal Y As Long)
Private Sub Class_Terminate()
    If m_Hwnd > 0 Then
        DetachMessage Me, m_Hwnd, WM_MOUSEWHEEL
    End If
End Sub
Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
    '
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse
    '
End Property

Private Function ISubclass_WindowProc(ByVal Hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim nValue As Long
    Dim nEvent As Long
    Dim X As Long
    Dim Y As Long
    Dim Rotation As Long
    Select Case iMsg
        Case WM_MOUSEWHEEL
            Rotation = wParam / 65536
            X = LoWord(lParam)
            Y = HiWord(lParam)
            RaiseEvent MouseWheel(Rotation, X, Y) '触发事件
    End Select
End Function

Public Sub HookGrid(ByVal Hwnd As Long)
    m_Hwnd = Hwnd
    AttachMessage Me, m_Hwnd, WM_MOUSEWHEEL
End Sub
Private Function LoWord(ByRef uParam As Long) As Long
    Dim n As Long
    n = 0
    CopyMemory ByVal VarPtr(n), ByVal VarPtr(uParam), 2
    LoWord = n
End Function
Private Function HiWord(ByRef uParam As Long) As Long
    Dim n As Long
    n = 0
    CopyMemory ByVal VarPtr(n), ByVal VarPtr(uParam) + 2, 2
    HiWord = n
End Function