powered by simpleCommunicator - 2.0.51     © 2025 Programmizd 02
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Excel VBA/Listbox прокрутка колесиком мыши
13 сообщений из 13, страница 1 из 1
Excel VBA/Listbox прокрутка колесиком мыши
    #38730814
sernikel
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Добрый день уважаемые форумчане.
Проблема с Listbox , когда перечень элементов превышает границы отображения появляется скролл, беда в том, что он не реагирует на прокрутку колесиком мыши, а клацать мышкой коллегам не удобно.
Как можно настроить, что бы listbox реагировал на колесико мыши?
Спасибо!

P.S.
Во вложении несколько файлов в которых я хотел бы это сделать, необходимо разархивировать и запустить excel файл. Мне не суть важно именно в моем файле это делать, подойдет самый простой вариант от вас.
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38730896
Фотография VSVLAD
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
sernikel,

Необходим сабклассинг. Создать процедуру обрабатывающую сообщения WM_MOUSEWHEEL.
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38731019
Фотография Antonariy
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
VSVLADНеобходим сабклассинг. Создать процедуру обрабатывающую сообщения WM_MOUSEWHEEL.в VBA это будет ахтунг. особенно учитывая, что у vba-контролов нет собственных окон.
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38733780
Фотография VladConn
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
В форме:

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
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



В модуле:

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
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

...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38738055
Здравствуйте, уважаемые форумчане! я начинающий пользователь макросов в Excel. Смотрела информацию на сайте http://www.sql.ru Для начала обучения мне понравилось. Может кому пригодится!
Модератор:
исправил ссылку :D
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38738318
Фотография The_Prist
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
начинающий пользователь,
Задолбали уже свой недосайт на ровном месте рекламировать без ссылок на конкретные решения по теме.
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38738440
Фотография Antonariy
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
The_Pristначинающий пользователь,
Задолбали уже свой недосайт на ровном месте рекламировать без ссылок на конкретные решения по теме.говно какое-то
сбор емейлов для спам-рассылок.
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38741614
sernikel
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
VladConnВ форме:

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
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



В модуле:

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
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




Добрый день.
Спасибо за помощь, единственное, что смущает, когда открывается форма прокрутка не работает, как только переключаюсь на другие windows приложения/окна и возвращаюсь обратно в форму прокрутка срабатывает. С чем это может быть связано и как решить данную проблему?
Спасибо!
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38741728
Фотография Antonariy
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
если при открытии файла он не находит базу, то при открытии диалога выбора сабклассинг падает, унося за собой эксель с прочими открытыми документами.
как я и предупреждал, ахтунг.
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38745032
Фотография VladConn
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
sernikel,

Hормального решения нет, но сплэш форма немного поможет:

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
В форме UserForm1:

Private blnOK As Boolean

Private Sub f2()

    If Not blnOK Then
        blnOK = True
        UserForm2.Show
        Unload UserForm2
    End If
End Sub


Private Sub UserForm_Activate()

    WheelHook Me 'For scrolling support
    
    f2

End Sub
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38779042
sernikel
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Спасибо!
В принципе сделал след.костыль, при нажатии на listbox, появляется и исчезает вторая форма, благодаря чему активируется колесиком мыши.
...
Рейтинг: 0 / 0
Excel VBA/Listbox прокрутка колесиком мыши
    #38780461
sernikel
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
В принципе, как вариант, ещё "для прокрутки щелкаем по любому пункту листбокса, и, НЕ ОТПУСКАЯ ЛЕВУЮ КНОПКУ МЫШИ, тянем мыша вниз. "
...
Рейтинг: 0 / 0
Период между сообщениями больше года.
Excel VBA/Listbox прокрутка колесиком мыши
    #39638021
Pi_Tri
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
VladConn,

Попытался адаптировать этот код под 64 бит:

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
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





Модератор: Учимся использовать тэги оформления кода - FAQ

Однако после вызова SetWindowLongPtr Excel2016 уходит в несознанку... LocalHwnd не нулевой, Err.LastDllError показывает 0, куда копать дальше?
...
Рейтинг: 0 / 0
13 сообщений из 13, страница 1 из 1
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Excel VBA/Listbox прокрутка колесиком мыши
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]