Требуется ScrollBar чувствительный к колесику мышки

[BorisSS]

Мож вопрос и ламерский, но тот, что у меня в стандартном комплекте ОСХов на колесико не реагирует
Заранее СПАСИБО!

[Ramzes]

Что то мне подсказывает что придется юзать АПИ

[A.A.Z.]

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

Option Explicit

Private Const PM_REMOVE = &H1
Private Const WM_MOUSEWHEEL = 522

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

Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long

Private bCancel As Boolean

Private Sub ProcessMessages()
Dim Message As Msg
Do While Not bCancel
WaitMessage
If PeekMessage(Message, Me.hWnd, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
On Error Resume Next
If Message.wParam < 0 Then
VScroll1.Value = VScroll1.Value + 500 'скролл вверх
Else
VScroll1.Value = VScroll1.Value - 500 'скролл вниз
End If
End If
DoEvents
Loop
End Sub

Private Sub Form_Load()
Me.Show
ProcessMessages
End Sub

Private Sub Form_Unload(Cancel As Integer)
bCancel = True
End Sub


[BorisSS]

Просто СУПЕР!!! Спасибо!

Вот только при длительном кручении колесика, возникает переполнение стэка и выскакивает ошибка №28. Я так понимаю, его надо периодически чистить, но КАК? Или еще где собака порылась?
ЗЫ: этот скролбар делает у меня ресайз картинки, может быть из-за этого происходит переполнение?

[A.A.Z.]

ХЗ... Может, так получится?.. (HideCaret я для красоты добавил, просто в первый раз забыл )

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

Option Explicit

Private Const PM_REMOVE = &H1
Private Const WM_MOUSEWHEEL = 522

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

Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function HideCaret Lib "user32" (ByVal hwnd As Long) As Long

Private bCancel As Boolean

Private Sub ProcessMessages()
Dim Message As Msg
Do While Not bCancel
WaitMessage
If PeekMessage(Message, Me.hwnd, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
If Message.wParam < 0 Then
If VScroll1.Value + 500 > VScroll1.Max Then VScroll1.Value = VScroll1.Max Else VScroll1.Value = VScroll1.Value + 500 'скролл вверх
Else
If VScroll1.Value - 500 < VScroll1.Min Then VScroll1.Value = VScroll1.Min Else VScroll1.Value = VScroll1.Value - 500 'скролл вниз
End If
End If
DoEvents
Loop
End Sub

Private Sub Form_Load()
Me.Show
ProcessMessages
End Sub

Private Sub Form_Unload(Cancel As Integer)
bCancel = True
End Sub

Private Sub VScroll1_Change()
HideCaret VScroll1.hwnd
End Sub

Private Sub VScroll1_GotFocus()
HideCaret VScroll1.hwnd
End Sub

Private Sub VScroll1_LostFocus()
HideCaret VScroll1.hwnd
End Sub

Private Sub VScroll1_Scroll()
HideCaret VScroll1.hwnd
End Sub

[BorisSS]

Спасибо! Первый вариант тоже нормально работает. Вся проблема была в том, что я вызывал процедуру из события нажатия клавиши и это вызывало каскадирование событий.