Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal HWnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long
'API函数 CallWindowProc 说明如下 'lpPrevWndFunc Long, 原来的窗口过程地址 'HWnd Long, 窗口句柄 'Msg Long, 发送的消息 'wParam Long, 消息类型,参考wParam参数表 'lParam Long, 依据wParam参数的不同而不同 Private 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
Private Const GWL_WNDPROC As Long = (-4) Private Const WM_MOUSEWHEEL As Long = &H20A
Public m_OldWindowProc As Long Public CtlWheel As Object '定义一个全局对象
Public Sub HookWheel(ByVal frmHwnd) 'frmHand是窗体的句柄 '在窗口结构中为指定的窗口设置信息 'GWL_WNDPROC 该窗口的窗口函数的地址 m_OldWindowProc = SetWindowLong(frmHwnd, GWL_WNDPROC, AddressOf pvWindowProc) '将当前窗体的信息存在私有变量 m_OldWindowProc 中 End Sub
Public Sub UnHookWheel(ByVal HWnd As Long) Dim lngReturnValue As Long lngReturnValue = SetWindowLong(HWnd, GWL_WNDPROC, m_OldWindowProc)
End Sub
Public Function pvWindowProc(ByVal HWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long On Error GoTo errH
Select Case wMsg Case WM_MOUSEWHEEL If Not CtlWheel Is Nothing Then If (TypeOf CtlWheel Is MSFlexGrid) Or (TypeOf CtlWheel Is MSHFlexGrid) Then With CtlWheel Select Case wParam Case Is > 0 If CtlWheel.TopRow > 0 Then CtlWheel.TopRow = CtlWheel.TopRow - 1 End If Case Else CtlWheel.TopRow = CtlWheel.TopRow + 1 End Select End With End If End If End Select
errH:
pvWindowProc = CallWindowProc(m_OldWindowProc, HWnd, wMsg, wParam, lParam) End Function