支持鼠标滚轮.bas

软件用到的技巧：透明窗体

Attribute VB_Name = "Module4"
Option Explicit

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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


Private m_OldWindowProc As Long

Public CtlWheel As Object

Public Sub HookWheel(ByVal frmHwnd)

    m_OldWindowProc = SetWindowLong(frmHwnd, GWL_WNDPROC, AddressOf pvWindowProc)
End Sub

Public Sub UnHookWheel(ByVal hwnd As Long)
    Dim lngReturnValue As Long
    lngReturnValue = SetWindowLong(hwnd, GWL_WNDPROC, m_OldWindowProc)
    
End Sub

Private 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 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

''''''''''''''以下是在窗口中需要调用的语句及函数说明等'''''''''''''''''''''''''''''''''''''''''''

'Private Sub MSFlexGrid1_GotFocus()


'Set CtlWheel = MSFlexGrid1 '用于设定支持鼠标滚轮


'End Sub

'Private Sub MSFlexGrid1_LostFocus()


'Set CtlWheel = Nothing '用于设定取消鼠标滚轮的支持


'End Sub
'Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)


'UnHookWheel Me.hwnd '卸载鼠标滚轮的支持


'End Sub

'Private Sub Form_Load()


'HookWheel Me.hwnd '用于支持鼠标滚轮


'End Sub