Excel VBA/Listbox прокрутка колесиком мыши
Формулировка задачи:
Добрый день.
Проблема с Listbox , когда перечень элементов превышает границы отображения появляется скролл, беда в том, что он не реагирует на прокрутку колесиком мыши, а клацать мышкой коллегам не удобно.
Как можно настроить, что бы listbox реагировал на колесико мыши?
Спасибо!
P.S.
Во вложении несколько файлов в которых я хотел бы это сделать, необходимо разархивировать и запустить excel файл. Мне не суть важно именно в моем файле это делать, подойдет самый простой вариант от вас.
Проблема с Listbox , когда перечень элементов превышает границы отображения появляется скролл, беда в том, что он не реагирует на прокрутку колесиком мыши, а клацать мышкой коллегам не удобно.
Как можно настроить, что бы listbox реагировал на колесико мыши?
Спасибо!
P.S.
Во вложении несколько файлов в которых я хотел бы это сделать, необходимо разархивировать и запустить excel файл. Мне не суть важно именно в моем файле это делать, подойдет самый простой вариант от вас.
Решение задачи: «Excel VBA/Listbox прокрутка колесиком мыши»
textual
Листинг программы
Private Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "USER32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
'To be able to scroll with mouse wheel within Userform
Private Declare PtrSafe Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As LongPtr, _
ByVal hWnd As LongPtr, _
ByVal Msg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Dim LocalHwnd As LongPtr
Dim LocalPrevWndProc As LongPtr
Dim myForm As UserForm
Public Function WindowProc(ByVal Lwnd As LongPtr, ByVal Lmsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
On Error Resume Next
'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(Caption As String)
'To get mouse events in userform
On Error Resume Next
'Set myForm = PassedForm
LocalHwnd = FindWindow("ThunderDFrame", Caption)
'MsgBox Err.LastDllError, , "FindWindow"
LocalPrevWndProc = SetWindowLongPtr(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook()
'To Release Mouse events handling
Dim WorkFlag As LongPtr
On Error Resume Next
WorkFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
Set myForm = Nothing
End Sub