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

Узнай цену своей работы

Формулировка задачи:

Добрый день.
Проблема с 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

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

8   голосов , оценка 4.125 из 5
Похожие ответы