MouseScrolling

[DemonTol]

Как "заставить" записи в DataGrid, MSFlexGrid и т.д. прокручиваться MouseScroll'ом. Сразу признаюсь - ч/з поиск искал, не нашел (может не так искал); MSDN у меня нет; в той литературе,которая у меня есть, тоже не нашел. Так что,

[Twister]

Это не совсем просто.
Тебе нужно знать, что при прокручивании колесика окну посылается сообщение WM_MOUSEWHEEL. Отсюда и пляши...

[GSerg]

Мой класс DataGridWheelSupport.cls

Где лежит subclasser, сами знаете.

Код: Выделить всё

Option Explicit

Implements ISubclass

Private Declare Function SystemParametersInfo Lib "user32.dll" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Const SPI_GETWHEELSCROLLLINES As Long = 104
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const WHEEL_DELTA As Long = 120

Private mGrid As DataGrid

Public Sub Start(ByVal g As DataGrid)
  If Not mGrid Is Nothing Then SubClasser.RemoveSubclassHook mGrid.hWnd
 
  Set mGrid = g
  SubClasser.AddSubclassHook g.hWnd, Me, DoNotTransfer
End Sub

Public Sub Stopp()
  If Not mGrid Is Nothing Then
    SubClasser.RemoveSubclassHook mGrid.hWnd
    Set mGrid = Nothing
  End If
End Sub

Private Function GetNumberOfLinesToScroll() As Long
  SystemParametersInfo SPI_GETWHEELSCROLLLINES, 0, GetNumberOfLinesToScroll, 0
End Function

Private Function ISubclass_Callback(ByVal hWnd As Long, uMsg As Long, wParam As Long, lParam As Long, ByVal PrevProc As Long) As Long
  Static Delta As Long
 
  If uMsg = WM_MOUSEWHEEL Then
    Delta = Delta + wParam / &H10000
    If Abs(Delta) >= WHEEL_DELTA Then
      mGrid.Scroll 0, -GetNumberOfLinesToScroll * (Delta \ WHEEL_DELTA)
      Delta = Delta Mod WHEEL_DELTA
    End If
    ISubclass_Callback = 0
  Else
    ISubclass_Callback = SubClasser.CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)
  End If
End Function

[DemonTol]

2Twister
Типа: IF указатель мыши нах-ся над DataGrid AND происходит ScrollUp Or ScrollDawn Then событие; (событие тоже, что и при VScrollBar)?

[DemonTol]

2GSerg
Спасибо, но для меня пока трудновато разобраться в твоем коде (с наскока). Конечно приятно когда подсказывают почти готовое решение, но мне хочется понять принцип действия. Если пойму принцип (суть) дальше сам.
P.S. Как говорится пинок в нужном направлении

[Twister]

Типа: IF указатель мыши нах-ся над DataGrid AND происходит ScrollUp Or ScrollDawn Then событие; (событие тоже, что и при VScrollBar)?

Нет, надо сабклассить...

[MeMBus]

P.S. Как говорится пинок в нужном направлении

Так GSerg и пишет:

Код: Выделить всё

Private Function ISubclass_Callback... 
  If uMsg = WM_MOUSEWHEEL Then...

Тут вся идея...

[farbox]

я чего то не пойму. подскажите кто нить плиз. я создал класс, вставил в него приведённый выше код. А VB 6.0 у меня ругается, типа

Object module needs to implement 'MsgResponse' for interface 'ISubclass'

и это ругательство происходит на строчке

Implements ISubclass

как мне это побороть ?
где найти этот MsgResponse ?

[GSerg]

Где лежит subclasser, сами знаете.

А не знаете, введите это слово в поиск (наверху, выделен красным).

[farbox]

извините конечно , но я с классами дела не имел , не приходилось. я новичёк в VB 6.0 .
Искал по форуму ...... даже нашёл выложенные вами тестовый проект..... ну нефига не могу разобраться , можите мне ну хоть чуть чуть популярно объяснить в чём сдесь дело ?

[GSerg]

Взять сабклассер, включить в свой проект три его файла с кодом. Собственно всё.

[farbox]

да , теперь без ошибок , но скролл по прежнему не работает ......
что делать то ?

[GSerg]

Наверное, использовать DataGridWheelSupport, а не просто поместить его в проект?..

[Andrey Fedorov]

да , теперь без ошибок , но скролл по прежнему не работает ......
что делать то ?

Код: Выделить всё

  If uMsg = WM_MOUSEWHEEL Then...

В выше приведенной строчке кода вместо ... должен быть код скроллирующий нужны тебе объект.

[GSerg]

Andrey Fedorov, твоя мысль мне совершенно не ясна.

[Andrey Fedorov]

Andrey Fedorov, твоя мысль мне совершенно не ясна.

А что тут не ясного?
Я делаю так - есть класс CMouseWheels:

Код: Выделить всё

Option Explicit

Implements SSubTimer6.ISubclass

Private Const WM_MouseWheel = &H20A
Private m_hWnd As Long

Public Event MouseWheel(RollUp As Boolean)

Public Sub Create(hWnd As Long)
    If hWnd Then m_hWnd = hWnd: AttachMessage Me, m_hWnd, WM_MouseWheel
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse)
    '
End Property

Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse
    ISubclass_MsgResponse = emrPostProcess
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case iMsg
        Case WM_MouseWheel: RaiseEvent MouseWheel(wParam > 0)
    End Select
End Function

Private Sub Class_Terminate()
    If m_hWnd Then DetachMessage Me, m_hWnd, WM_MouseWheel: m_hWnd = 0
End Sub


В форме стоит:

Код: Выделить всё

        Set m_CMW = New CMouseWheels
        m_CMW.Create MyPictureBox.hWnd


И уже по событию MouseWheel в форме скролирую то что нужно.
Например, перерисовываю содержимое PictureBox-a.

[GSerg]

Andrey Fedorov, тогда прочитай топик сначала, что ли, и код посмотри внимательно, а то совсем сейчас неясно стало, к чему было http://bbs.vbstreets.ru/viewtopic.php?p=6639292#6639292