Как отловить скроллинг колесом мыши?

[Nikita]

Есть форма, на ней кроме всего прочего есть список ListBox, перезаполненный т.е. со скроллбаром.
Нужно все кручения колесика мыши над формой передавать скроллированию этого списка, как если бы список был в фокусе, как такое сделать?

Кстати, интересный факт, отлов сообщений через Spy++ - движения мыши типа WM_MOUSEMOVE ловятся, а кручение колеса мыши - их оно не видит! При этом список (если на нем фокус) нормально скроллится, появляются сообщения его перерисовки.

[Q2W]

Хе хе. Я тоже хочу!!! Как я тебе помог, а?

[angelina]

не знаю, поможет ли это, но я могу дать код, как отловить событие прокрутки колесиком над формой, а дальше тебе надо что-то делать с листом. Вообщем, если нужно, то дай знать.

[Sergey-13]

я бы скачал такой пример. не к спеху но вскором времени понадбиться.

[Человек]

!!! Здесь не код нужен, а ActiveX контрол!!!
http://www.shnyr-ok.narod.ru/Mouse.zip
12kb

[A.A.Z.]

Поставь на форму таймер с интервалом в 1 и заполненный листбокс. Правда, тормозит жутко, но если подработать...

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

Const WM_MOUSEWHEEL = &H20A
Const Mouse_Scroll = &H780000
Private Type POINTAPI
X As Long
Y As Long
End Type

Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type

Dim mMsg As MSG
Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, _
ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long

Function GetNapr() As Long
Dim lMsg As Long
Dim Napr As Long
DoEvents
Call GetMessage(mMsg, Me.hwnd, 0, 0)
DoEvents
lMsg = mMsg.message
DoEvents
Napr = mMsg.wParam
DoEvents
If lMsg = 522 Then
DoEvents
If Napr = Mouse_Scroll Then
DoEvents
GetNapr = 1
DoEvents
ElseIf Napr = -Mouse_Scroll Then
DoEvents
GetNapr = -1
DoEvents
Else
DoEvents
GetNapr = 0
DoEvents
End If
DoEvents
End If
DoEvents
End Function

Private Sub Timer1_Timer()
Static a As Boolean
If a <> True Then GoTo 10
List1.ListIndex = 0
a = True
10 If GetNapr = 1 Then
DoEvents
If List1.ListIndex <= 0 Then Exit Sub
DoEvents
List1.ListIndex = List1.ListIndex - 1
DoEvents
ElseIf GetNapr = -1 Then
DoEvents
If List1.ListIndex = List1.ListCount - 1 Then Exit Sub
DoEvents
List1.ListIndex = List1.ListIndex + 1
Else
DoEvents
End If
DoEvents
End Sub


[Vasya]

А что, сабклассинг не помогает??

[Tamahawk]

Человек.
!!! Здесь не код нужен, а ActiveX контрол!!!
http://www.shnyr-ok.narod.ru/Mouse.zip

У тя в mouse.OCX-е mouse.DEP-а нету

[Tamahawk]

A.A.Z
я вижу у тя длинный и не очень эффективный код.

Никита используй глобальный хук, поставь на форму таймер (интервал можеш = 100)
и эта ерунда в модуле

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

Option Explicit
Public 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
Public Declare Function SetWindowLongA Lib "user32" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = -4
Public Const WM_MOUSEWHEEL = &H20A
Public OldWindowProc As Long, Wheel As Integer
' wParam 7864320 Or 23592960 Or 15728640
Public Sub Hook(Hwnd As Long)
    OldWindowProc = SetWindowLongA(Hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub
Public Function NewWindowProc(ByVal Hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = WM_MOUSEWHEEL Then Wheel = IIf(wParam < 0, -1, 1)
    NewWindowProc = CallWindowProcA(OldWindowProc, Hwnd, Msg, wParam, lParam)
End Function

а эо в ж..

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

Option Explicit
Private Sub Form_Load()
    Call Hook(Me.Hwnd)
    tmrGet.Enabled = True
End Sub

Private Sub tmrGet_Timer()
Me.Caption = "Идет " & Wheel
End Sub

это все работает, тока без листа. там уж сам по трудись