Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Скроллинг мышью в комбобоксах на листе. - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Скроллинг мышью в комбобоксах на листе.
votangi59 Дата: Понедельник, 20.01.2025, 12:50 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 36
Репутация: 0 ±
Замечаний: 0% ±

Задача: осуществить скроллинг мышью в комбобоксах на листе.
Имеется энное количество комбобоксов, строк около двухсот, выбор по первым символам не эффективен- много данных с повторяющимися первыми символами, скролл посредством полосы прокрутки и кнопками "вверх"/"вниз" крайне неудобен.
Начал работать с VBA недавно, знаний мало.
Знатоки, помогите пожалуйста, подскажите код или где есть что-нибудь на эту тему.
Буду весьма признателен за науку.


Сообщение отредактировал votangi59 - Понедельник, 20.01.2025, 14:09
 
Ответить
СообщениеЗадача: осуществить скроллинг мышью в комбобоксах на листе.
Имеется энное количество комбобоксов, строк около двухсот, выбор по первым символам не эффективен- много данных с повторяющимися первыми символами, скролл посредством полосы прокрутки и кнопками "вверх"/"вниз" крайне неудобен.
Начал работать с VBA недавно, знаний мало.
Знатоки, помогите пожалуйста, подскажите код или где есть что-нибудь на эту тему.
Буду весьма признателен за науку.

Автор - votangi59
Дата добавления - 20.01.2025 в 12:50
votangi59 Дата: Понедельник, 27.01.2025, 10:32 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 36
Репутация: 0 ±
Замечаний: 0% ±

Всех приветствую!
Не поверю, что ни кто не знает, здесь такие грамотные люди.
Может код длинный? Ответ нашёл на другом импортном ресурсе, но для меня не внятно, не понимаю что куда прикрутить, уровень знаний оставляет желать.
Подскажите, пожалуйста, что к чему здесь (для меня дремучий лес) )):

Solved, by Jaafar Tribak
the code i use currently (place it in any module):
Option Explicit

[vba]
Код
Type POINTAPI
X As Long
Y As Long
End Type

Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type

#If VBA7 Then
#If Win64 Then
Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongPtr
#Else
Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Dim hwnd As LongPtr, lMouseHook As LongPtr
#Else
Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Dim hwnd As Long, lMouseHook As Long
#End If

Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0

Dim oComboBox As Object

Sub SetComboBoxHook(ByVal Control As Object)
Dim tPt As POINTAPI
Dim sBuffer As String
Dim lRet As Long

Set oComboBox = Control
RemoveComboBoxHook
GetCursorPos tPt
#If Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, tPt, LenB(tPt)
hwnd = WindowFromPoint(lPt)
#Else
hwnd = WindowFromPoint(tPt.X, tPt.Y)
#End If
sBuffer = Space(256)
lRet = GetClassName(GetParent(hwnd), sBuffer, 256)
If InStr(Left(sBuffer, lRet), "MdcPopup") Then
SetFocus hwnd
#If Win64 Then
lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.HinstancePtr, 0)
#Else
lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
#End If
End If
End Sub

Sub RemoveComboBoxHook()
UnhookWindowsHookEx lMouseHook
End Sub

#If VBA7 Then
Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
#Else
Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
#End If

Dim sBuffer As String
Dim lRet As Long

sBuffer = Space(256)
lRet = GetClassName(GetActiveWindow, sBuffer, 256)
If Left(sBuffer, lRet) = "wndclass_desked_gsk" Then Call RemoveComboBoxHook
If IsWindow(hwnd) = 0 Then Call RemoveComboBoxHook

If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
#If Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, lParam.pt, LenB(lParam.pt)
If WindowFromPoint(lPt) = hwnd Then
#Else
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = hwnd Then
#End If
On Error Resume Next
If lParam.mouseData > 0 Then
oComboBox.TopIndex = oComboBox.TopIndex - 1 '<---u can change this to change the scrolling speed upwards
'u can change "TopIndex" to "listIndex" if you want to change the value instead of hovering it, do not use the dynamic listFillrange if u do!
Else
oComboBox.TopIndex = oComboBox.TopIndex + 2 '<---u can change this to change the scrolling speed downwards
'u can change "TopIndex" to "listIndex" if you want to change the value instead of hovering it, do not use the dynamic listFillrange if u do!
End If
On Error GoTo 0
End If
End If

MouseProc = CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
End Function

he combobox code (view code to the combobox):
Option Explicit

'optional
Dim ComboBoxRange As Range
Dim myRange As Range
Dim NumRows
'optional
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call SetComboBoxHook(ComboBox1)
End Sub

Private Sub ComboBox1_LostFocus()
Call RemoveComboBoxHook
End Sub

'optional, this code is for a dynamic list, do not use if u changed TopIndex to ListIndex!
'importent note...u need a dynamic list to begin with if u want to use it!
Private Sub ComboBox1_Change()
Set myRange = Range("Q:Q") 'the range of data
NumRows = Application.WorksheetFunction.Count(myRange)
'////////////////////////////////////////////////////////////////
Set ComboBoxRange = Range(Cells(4, 17), Cells(3 + NumRows, 17))
'my data starts at range Q4, Q = 17, A=1, change this according to the range you want to change
'////////////////////////////////////////////////////////////////
ComboBox1.ListFillRange = ComboBoxRange.Cells.Address
ComboBox1.DropDown
End Sub
'optional
[/vba]


Сообщение отредактировал votangi59 - Понедельник, 27.01.2025, 10:38
 
Ответить
СообщениеВсех приветствую!
Не поверю, что ни кто не знает, здесь такие грамотные люди.
Может код длинный? Ответ нашёл на другом импортном ресурсе, но для меня не внятно, не понимаю что куда прикрутить, уровень знаний оставляет желать.
Подскажите, пожалуйста, что к чему здесь (для меня дремучий лес) )):

Solved, by Jaafar Tribak
the code i use currently (place it in any module):
Option Explicit

[vba]
Код
Type POINTAPI
X As Long
Y As Long
End Type

Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type

#If VBA7 Then
#If Win64 Then
Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongPtr
#Else
Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Dim hwnd As LongPtr, lMouseHook As LongPtr
#Else
Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Dim hwnd As Long, lMouseHook As Long
#End If

Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0

Dim oComboBox As Object

Sub SetComboBoxHook(ByVal Control As Object)
Dim tPt As POINTAPI
Dim sBuffer As String
Dim lRet As Long

Set oComboBox = Control
RemoveComboBoxHook
GetCursorPos tPt
#If Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, tPt, LenB(tPt)
hwnd = WindowFromPoint(lPt)
#Else
hwnd = WindowFromPoint(tPt.X, tPt.Y)
#End If
sBuffer = Space(256)
lRet = GetClassName(GetParent(hwnd), sBuffer, 256)
If InStr(Left(sBuffer, lRet), "MdcPopup") Then
SetFocus hwnd
#If Win64 Then
lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.HinstancePtr, 0)
#Else
lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
#End If
End If
End Sub

Sub RemoveComboBoxHook()
UnhookWindowsHookEx lMouseHook
End Sub

#If VBA7 Then
Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
#Else
Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
#End If

Dim sBuffer As String
Dim lRet As Long

sBuffer = Space(256)
lRet = GetClassName(GetActiveWindow, sBuffer, 256)
If Left(sBuffer, lRet) = "wndclass_desked_gsk" Then Call RemoveComboBoxHook
If IsWindow(hwnd) = 0 Then Call RemoveComboBoxHook

If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
#If Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, lParam.pt, LenB(lParam.pt)
If WindowFromPoint(lPt) = hwnd Then
#Else
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = hwnd Then
#End If
On Error Resume Next
If lParam.mouseData > 0 Then
oComboBox.TopIndex = oComboBox.TopIndex - 1 '<---u can change this to change the scrolling speed upwards
'u can change "TopIndex" to "listIndex" if you want to change the value instead of hovering it, do not use the dynamic listFillrange if u do!
Else
oComboBox.TopIndex = oComboBox.TopIndex + 2 '<---u can change this to change the scrolling speed downwards
'u can change "TopIndex" to "listIndex" if you want to change the value instead of hovering it, do not use the dynamic listFillrange if u do!
End If
On Error GoTo 0
End If
End If

MouseProc = CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
End Function

he combobox code (view code to the combobox):
Option Explicit

'optional
Dim ComboBoxRange As Range
Dim myRange As Range
Dim NumRows
'optional
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call SetComboBoxHook(ComboBox1)
End Sub

Private Sub ComboBox1_LostFocus()
Call RemoveComboBoxHook
End Sub

'optional, this code is for a dynamic list, do not use if u changed TopIndex to ListIndex!
'importent note...u need a dynamic list to begin with if u want to use it!
Private Sub ComboBox1_Change()
Set myRange = Range("Q:Q") 'the range of data
NumRows = Application.WorksheetFunction.Count(myRange)
'////////////////////////////////////////////////////////////////
Set ComboBoxRange = Range(Cells(4, 17), Cells(3 + NumRows, 17))
'my data starts at range Q4, Q = 17, A=1, change this according to the range you want to change
'////////////////////////////////////////////////////////////////
ComboBox1.ListFillRange = ComboBoxRange.Cells.Address
ComboBox1.DropDown
End Sub
'optional
[/vba]

Автор - votangi59
Дата добавления - 27.01.2025 в 10:32
MikeVol Дата: Понедельник, 27.01.2025, 16:13 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 389
Репутация: 84 ±
Замечаний: 0% ±

MSO LTSC 2021 EN
votangi59, Вот откуда вы взяли код там и спросите. Кстати, там и файл прилагается, вот его покрутите. А так без вашего файла примера тяжко будет вам чем-то помочь. Удачи.


Ученик.
Одесса - Украина
 
Ответить
Сообщениеvotangi59, Вот откуда вы взяли код там и спросите. Кстати, там и файл прилагается, вот его покрутите. А так без вашего файла примера тяжко будет вам чем-то помочь. Удачи.

Автор - MikeVol
Дата добавления - 27.01.2025 в 16:13
votangi59 Дата: Вторник, 28.01.2025, 09:06 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 36
Репутация: 0 ±
Замечаний: 0% ±

Приветствую, MikeVol. Благодарю за ответ.
Файла там я не увидел. https://stackoverflow.com/questio....h-mouse
С файлом примера сложновато будет, конфиденциальная информация, да и файл по объёму великоват. Но попробую удалить лишнее и выложить.
Попытаюсь сам, методом научного тыка, как-нибудь прикрутить.


Сообщение отредактировал votangi59 - Вторник, 28.01.2025, 09:13
 
Ответить
СообщениеПриветствую, MikeVol. Благодарю за ответ.
Файла там я не увидел. https://stackoverflow.com/questio....h-mouse
С файлом примера сложновато будет, конфиденциальная информация, да и файл по объёму великоват. Но попробую удалить лишнее и выложить.
Попытаюсь сам, методом научного тыка, как-нибудь прикрутить.

Автор - votangi59
Дата добавления - 28.01.2025 в 09:06
MikeVol Дата: Вторник, 28.01.2025, 10:11 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 389
Репутация: 84 ±
Замечаний: 0% ±

MSO LTSC 2021 EN
votangi59, Так вот же пример. Сама тема: ComboBox Scroll with Mouse wheel
Там много чего интересного найдёте для себя. Файл пример от вас не нужен уже. Сами разберётесь. Удачи.
К сообщению приложен файл: ComboMouseWheel.xls (70.5 Kb)


Ученик.
Одесса - Украина
 
Ответить
Сообщениеvotangi59, Так вот же пример. Сама тема: ComboBox Scroll with Mouse wheel
Там много чего интересного найдёте для себя. Файл пример от вас не нужен уже. Сами разберётесь. Удачи.

Автор - MikeVol
Дата добавления - 28.01.2025 в 10:11
votangi59 Дата: Вторник, 28.01.2025, 22:56 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 36
Репутация: 0 ±
Замечаний: 0% ±

Благодарю, MikeVol.
Буду пробовать. Много чего непонятного, мои познания весьма скудны, но как говорится, ещё не вечер.
Будем понемногу грызть гранит науки.
Желаю вам всего хорошего!
 
Ответить
СообщениеБлагодарю, MikeVol.
Буду пробовать. Много чего непонятного, мои познания весьма скудны, но как говорится, ещё не вечер.
Будем понемногу грызть гранит науки.
Желаю вам всего хорошего!

Автор - votangi59
Дата добавления - 28.01.2025 в 22:56
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!