Задача: осуществить скроллинг мышью в комбобоксах на листе. Имеется энное количество комбобоксов, строк около двухсот, выбор по первым символам не эффективен- много данных с повторяющимися первыми символами, скролл посредством полосы прокрутки и кнопками "вверх"/"вниз" крайне неудобен. Начал работать с VBA недавно, знаний мало. Знатоки, помогите пожалуйста, подскажите код или где есть что-нибудь на эту тему. Буду весьма признателен за науку.
Задача: осуществить скроллинг мышью в комбобоксах на листе. Имеется энное количество комбобоксов, строк около двухсот, выбор по первым символам не эффективен- много данных с повторяющимися первыми символами, скролл посредством полосы прокрутки и кнопками "вверх"/"вниз" крайне неудобен. Начал работать с VBA недавно, знаний мало. Знатоки, помогите пожалуйста, подскажите код или где есть что-нибудь на эту тему. Буду весьма признателен за науку.votangi59
Сообщение отредактировал votangi59 - Понедельник, 20.01.2025, 14:09
Всех приветствую! Не поверю, что ни кто не знает, здесь такие грамотные люди. Может код длинный? Ответ нашёл на другом импортном ресурсе, но для меня не внятно, не понимаю что куда прикрутить, уровень знаний оставляет желать. Подскажите, пожалуйста, что к чему здесь (для меня дремучий лес) )):
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
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]
Всех приветствую! Не поверю, что ни кто не знает, здесь такие грамотные люди. Может код длинный? Ответ нашёл на другом импортном ресурсе, но для меня не внятно, не понимаю что куда прикрутить, уровень знаний оставляет желать. Подскажите, пожалуйста, что к чему здесь (для меня дремучий лес) )):
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
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
votangi59, Вот откуда вы взяли код там и спросите. Кстати, там и файл прилагается, вот его покрутите. А так без вашего файла примера тяжко будет вам чем-то помочь. Удачи.
votangi59, Вот откуда вы взяли код там и спросите. Кстати, там и файл прилагается, вот его покрутите. А так без вашего файла примера тяжко будет вам чем-то помочь. Удачи.MikeVol
Приветствую, MikeVol. Благодарю за ответ. Файла там я не увидел. https://stackoverflow.com/questio....h-mouse С файлом примера сложновато будет, конфиденциальная информация, да и файл по объёму великоват. Но попробую удалить лишнее и выложить. Попытаюсь сам, методом научного тыка, как-нибудь прикрутить.
Приветствую, MikeVol. Благодарю за ответ. Файла там я не увидел. https://stackoverflow.com/questio....h-mouse С файлом примера сложновато будет, конфиденциальная информация, да и файл по объёму великоват. Но попробую удалить лишнее и выложить. Попытаюсь сам, методом научного тыка, как-нибудь прикрутить.votangi59
Сообщение отредактировал votangi59 - Вторник, 28.01.2025, 09:13
Благодарю, MikeVol. Буду пробовать. Много чего непонятного, мои познания весьма скудны, но как говорится, ещё не вечер. Будем понемногу грызть гранит науки. Желаю вам всего хорошего!
Благодарю, MikeVol. Буду пробовать. Много чего непонятного, мои познания весьма скудны, но как говорится, ещё не вечер. Будем понемногу грызть гранит науки. Желаю вам всего хорошего!votangi59