Excel VBA/Listbox прокрутка колесиком мыши

[sernik]

Добрый день уважаемые форумчане.
Проблема с Listbox , когда перечень элементов превышает границы отображения появляется скролл, беда в том, что он не реагирует на прокрутку колесиком мыши, а клацать мышкой коллегам не удобно.
Как можно настроить, что бы listbox реагировал на колесико мыши?
Спасибо!

P.S.
Во вложении несколько файлов в которых я хотел бы это сделать, необходимо разархивировать и запустить excel файл. Мне не суть важно именно в моем файле это делать, подойдет самый простой вариант от вас.

[EducatedFool]

http://www.planetaexcel.ru/forum/ind...#message495834

[sernik]

Мне подсказали след. образом:
VladConn
В форме:

Private Sub UserForm_Activate()
    WheelHook Me 'For scrolling support
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
WheelUnHook     'For scrolling support
'...
End Sub

Private Sub UserForm_Deactivate()
WheelUnHook     'For scrolling support
'...
End Sub

Public Sub MouseWheel(ByVal Rotation As Long)
'************************************************
' To respond from MouseWheel event
' Scroll accordingly to direction
'
' Made by:  Mathieu Plante
' Date:     July 2004
'************************************************
If Rotation > 0 Then
    'Scroll up
    If ListBox1.TopIndex > 0 Then
        If ListBox1.TopIndex > 3 Then
            ListBox1.TopIndex = ListBox1.TopIndex - 3
        Else
            ListBox1.TopIndex = 0
        End If
    End If
Else
    'Scroll down
    ListBox1.TopIndex = ListBox1.TopIndex + 3
End If
End Sub

В модуле:

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
   (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
      (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'To be able to scroll with mouse wheel within Userform

Private Declare Function CallWindowProc Lib "user32.dll" 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 = -4
Private Const WM_MOUSEWHEEL = &H20A

Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim myForm As UserForm

Private Function WindowProc(ByVal Lwnd As Long, ByVal Lmsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    'To handle mouse events
    Dim MouseKeys As Long
    Dim Rotation As Long
    
    If Lmsg = WM_MOUSEWHEEL Then
        MouseKeys = wParam And 65535
        Rotation = wParam / 65536
        'My Form s MouseWheel function
        UserForm1.MouseWheel Rotation
    End If
    WindowProc = CallWindowProc(LocalPrevWndProc, Lwnd, Lmsg, wParam, lParam)
End Function

Public Sub WheelHook(PassedForm As UserForm)
    'To get mouse events in userform
    On Error Resume Next
    
    Set myForm = PassedForm
    LocalHwnd = FindWindow("ThunderDFrame", myForm.Caption)
    LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub WheelUnHook()
    'To Release Mouse events handling
    Dim WorkFlag As Long
    
    On Error Resume Next
    WorkFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
    Set myForm = Nothing
End Sub

[EducatedFool]

Мне подсказали след. образом

вот насчет этого кода я и говорил, что работает нестабильно, Excel может зависать

т.е. сейчас-то оно всё работает, но в один прекрасный момент если зависнет, - Excel придётся закрывать через диспетчер задач, с потерей несохранённых данных.

Вот потому я от этого способа и отказался (лучше пусть будет меньше наворотов, - но всё будет стабильно работать)

[sernik]

Спасибо, кажется, по вашей ссылке и нашел его. Запамятывал
Несколько подсказали переделать, точнее сделать хитрость, т.к. пока не переключишся между окнами, скролл сходу не пашет :\
Не панацения, но как костыль норм.