Visual Basic FAQ

Прокрутка Grid’ов и ScrollBar’ов колесом мыша.
Код применим для «DataGrid», «DBGrid», «MSHFlexGrid», «MSFlexGrid», «VScrollBar», «HScrollBar»

Код формы:

Private Sub Form_Load()
    Call Hook(Me.hWnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call UnHook(Me.hWnd)
End Sub

Private Sub Form_Load()
    Call Hook(Me.hWnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call UnHook(Me.hWnd)
End Sub

Код модуля:

Option Explicit
Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private lpPrevWndProc As Long

Public Sub Hook(hWnd As Long)
    lpPrevWndProc = SetWindowLongA(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnHook(hWnd As Long)
    Call SetWindowLongA(hWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub

Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo xErr
If uMsg = WM_MOUSEWHEEL Then
    Dim Wheel As Long, iRow As Long
    Dim Contr As Object

    If wParam < 0 Then Wheel = -1
    If wParam > 0 Then Wheel = 1
    Set Contr = Screen.ActiveForm.ActiveControl
    Select Case TypeName(Contr)

    Case "MSHFlexGrid", "MSFlexGrid"
        iRow = Contr.TopRow
        If Not ((iRow = 1 And Wheel = 1) Or (iRow = Contr.Rows - 1 And Wheel = -1)) Then
            Contr.TopRow = iRow - Wheel
        End If
    Case "DataGrid", "DBGrid"
        Contr.Scroll 0, Wheel * -1
    Case "VScrollBar", "HScrollBar"
        iRow = Contr.Value
        If Not ((iRow = Contr.Min And Wheel = 1) Or (iRow = Contr.Max And Wheel = -1)) Then
            Contr.Value = iRow - Wheel
        End If
    End Select
    Set Contr = Nothing
Else
    WindowProc = CallWindowProcA(lpPrevWndProc, hWnd, uMsg, wParam, lParam)
End If
xErr:
End Function

Запись опубликована on 29.10.2009 at 9:00 и размещена в рубрике: Мышь. Вы можете читать комментарии, используя RSS-ленту. Вы можете оставить комментарий, или отправить трекбек с Вашего сайта.