Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1856to1860
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Scrollfunktion in Combobox
18.11.2021 12:41:28
Pascal
Hallo allerseits
Ich bin mir sicher, dies schon mal irgendwo hier gelesen zu haben, doch leider wurde ich trotz aller Bemühungen nicht mehr fündig :-(
Wie/Wo kann ich meine ComboBoxen (auf einer UserForm hab ich drei ComboBoxen) einstellen, dass deren Listeninhalte mit dem Mausrad scrollbar/auswählbar sind?
Vielen Dank für Eure Tipps!
Grüsse: Pascal

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Scrollfunktion in Combobox
18.11.2021 12:53:14
Nepumuk
Hallo Pascal,
im Modul des UserForms:

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call HookMouse(Me, ComboBox1)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call UnhookMouse
End Sub
Das MouseMove-Event musst du für jede ComboBox programmieren.
In einem Standardmodul (Menüleiste im VBA-Editor - Einfügen - Modul):

Option Explicit
Option Private Module
Private Declare PtrSafe Function GetWindowLongPtrA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" ( _
ByVal point As LongLong) As LongPtr
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32.dll" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As LongPtr)
Private Declare PtrSafe Function SetWindowsHookExA Lib "user32.dll" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr, _
ByVal ncode As Long, _
ByVal wParam As LongPtr, _
ByRef lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetKeyState Lib "user32.dll" ( _
ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Type POINTAPI
XY As LongLong
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
Private Const WH_MOUSE_LL As Long = 14&
Private Const WM_MOUSEWHEEL As LongPtr = &H20A
Private Const HC_ACTION As Long = 0&
Private Const GWL_HINSTANCE As Long = -6&
Private Const WM_KEYDOWN As Long = &H100
Private Const SCROLL_DOWN As LongPtr = &H780000
Private Const GC_CLASSNAMEUSERFORM As String = "ThunderDFrame"
Private llngptrMouseHook As LongPtr
Private llngptrControlHwnd As LongPtr
Private llngPage As Long
Private lblnHook As Boolean
Private lobjScrollObject As Object
Public Sub HookMouse(ByRef probjUserform As Object, ByRef probjScrollObject As Object, Optional ByVal opvlngPage As Long)
Dim lngptrHinstance As LongPtr
Dim lngptrFormHwnd As LongPtr
Dim lngptrHwndUnderCursor As LongPtr
Dim udtPoint As POINTAPI
llngPage = opvlngPage
Call GetCursorPos(udtPoint)
lngptrHwndUnderCursor = WindowFromPoint(udtPoint.XY)
If llngptrControlHwnd  lngptrHwndUnderCursor Then
Call UnhookMouse
Set lobjScrollObject = probjScrollObject
llngptrControlHwnd = lngptrHwndUnderCursor
lngptrFormHwnd = FindWindowA(GC_CLASSNAMEUSERFORM, probjUserform.Caption)
lngptrHinstance = GetWindowLongPtrA(lngptrFormHwnd, GWL_HINSTANCE)
If Not lblnHook Then
llngptrMouseHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, lngptrHinstance, 0&)
lblnHook = llngptrMouseHook  0
End If
End If
End Sub
Public Sub UnhookMouse()
If lblnHook Then
Call UnhookWindowsHookEx(llngptrMouseHook)
Set lobjScrollObject = Nothing
llngptrMouseHook = 0
llngptrControlHwnd = 0
lblnHook = False
End If
End Sub
Private Function MouseProc(ByVal pvlngCode As Long, ByVal pvlngptrParam As LongPtr, ByRef prudtParam As MOUSEHOOKSTRUCT) As LongPtr
Dim lngptrHwndUnderCursor As LongPtr
On Error GoTo err_exit
If pvlngCode = HC_ACTION Then
lngptrHwndUnderCursor = WindowFromPoint(prudtParam.pt.XY)
If lngptrHwndUnderCursor = llngptrControlHwnd Then
If pvlngptrParam = WM_MOUSEWHEEL Then
If TypeOf lobjScrollObject Is MSForms.ListBox Or TypeOf lobjScrollObject Is MSForms.ComboBox Or _
TypeOf lobjScrollObject Is MSForms.TextBox Then
With lobjScrollObject
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd = SCROLL_DOWN Then
If .TopIndex > 0 Then
If .TopIndex > 3 Then
.TopIndex = .TopIndex - 3
Else
.TopIndex = 0
End If
End If
Else
.TopIndex = .TopIndex + 3
End If
Else
If TypeOf lobjScrollObject Is MSForms.ListBox Or TypeOf lobjScrollObject Is MSForms.TextBox Then
If prudtParam.hwnd = SCROLL_DOWN Then
Call PostMessageA(llngptrControlHwnd, WM_KEYDOWN, vbKeyLeft, 0)
Else
Call PostMessageA(llngptrControlHwnd, WM_KEYDOWN, vbKeyRight, 0)
End If
End If
End If
End With
ElseIf TypeOf lobjScrollObject Is MSForms.MultiPage Then
With lobjScrollObject.Pages(llngPage)
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd = SCROLL_DOWN Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd = SCROLL_DOWN Then
If .ScrollLeft > 0 Then
.ScrollLeft = .ScrollLeft - 30
Else
.ScrollLeft = 0
End If
Else
.ScrollLeft = .ScrollLeft + 30
End If
End If
End With
ElseIf TypeOf lobjScrollObject Is MSForms.UserForm Or TypeOf lobjScrollObject Is MSForms.Frame Then
With lobjScrollObject
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd = SCROLL_DOWN Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd = SCROLL_DOWN Then
If .ScrollLeft > 0 Then
.ScrollLeft = .ScrollLeft - 30
Else
.ScrollLeft = 0
End If
Else
.ScrollLeft = .ScrollLeft + 30
End If
End If
End With
End If
Exit Function
End If
Else
Call UnhookMouse
End If
End If
MouseProc = CallNextHookEx(llngptrMouseHook, pvlngCode, pvlngptrParam, ByVal prudtParam)
Exit Function
err_exit:
Call UnhookMouse
End Function
Gruß
Nepumuk
Anzeige
AW: Scrollfunktion in Combobox
18.11.2021 14:12:17
Pascal
Grüss dich Nepomuk
Danke für deinen Lösungsvorschlag. Leider erhalte ich einen Fehler bei der Zeile
habe diesen Code in ein neues Standardmodul (Modul2) gesetzt

XY As LongLong
Fehler beim Kompilieren
Benutzerdefinierter Typ nicht definiert
Grüsse: Pascal
nur 1x Long (owT)
18.11.2021 14:14:53
Pierre
AW: nur 1x Long (owT)
18.11.2021 14:53:21
Pascal
Danke für den Hinweis
obwohl Long nur 1x steht jetzt, kann ich nach wie vor nicht scrollen in meinen drei Comboboxen
AW: nur 1x Long (owT)
18.11.2021 15:15:18
Pascal
es erscheint bereits der nächste Kompilierungsfehler:

Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" ( _
ByVal point As LongLong) As LongPtr
Grüsse: Pascal
Anzeige
AW: nur 1x Long (owT)
18.11.2021 15:22:11
volti
Hallo Pascal,
Nepumuk hat das für 64 Bit geschrieben.
Wenn Du das unter 32 Bit einsetzen möchtest, versuch es mal mit diesen Änderungen.
PS_ Longlong gibt es nur in der 64 Bit-Version.
Code:

[Cc]

Private Declare PtrSafe Function GetWindowLongPtrA Lib "user32" Alias "GetWindowLongA" ( _ ByVal hwnd As LongPtr, _ ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" ( _ ByVal point As Currency) As LongPtr Private Type POINTAPI XY As Currency End Type

viele Grüße
Karl-Heinz

Anzeige
AW: nur 1x Long (owT)
18.11.2021 15:36:22
Nepumuk
Hallo Pascal,
dann im Userform:

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call HookMouse(ComboBox1)
End Sub
Und in deinem Modul:

Option Explicit
Option Private Module
Private Declare PtrSafe Function GetWindowLongA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As LongPtr
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32.dll" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As LongPtr)
Private Declare PtrSafe Function SetWindowsHookExA Lib "user32.dll" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr, _
ByVal ncode As Long, _
ByVal wParam As LongPtr, _
ByRef lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetKeyState Lib "user32.dll" ( _
ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
Private Const WH_MOUSE_LL As Long = 14&
Private Const WM_MOUSEWHEEL As LongPtr = &H20A
Private Const HC_ACTION As Long = 0&
Private Const GWL_HINSTANCE As Long = -6&
Private Const WM_KEYDOWN As Long = &H100
Private llngptrMouseHook As LongPtr
Private llngptrControlHwnd As LongPtr
Private llngPage As Long
Private lblnHook As Boolean
Private lobjScrollObject As Object
Public Sub HookMouse(ByRef probjScrollObject As Object, Optional ByVal opvlngPage As Long)
Dim lngptrHinstance As LongPtr
Dim lngptrHwndUnderCursor As LongPtr
Dim udtPoint As POINTAPI
llngPage = opvlngPage
Call GetCursorPos(udtPoint)
lngptrHwndUnderCursor = WindowFromPoint(udtPoint.X, udtPoint.Y)
If llngptrControlHwnd  lngptrHwndUnderCursor Then
Call UnhookMouse
Set lobjScrollObject = probjScrollObject
llngptrControlHwnd = lngptrHwndUnderCursor
lngptrHinstance = GetWindowLongA(llngptrControlHwnd, GWL_HINSTANCE)
If Not lblnHook Then
llngptrMouseHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, lngptrHinstance, 0&)
lblnHook = llngptrMouseHook  0
End If
End If
End Sub
Public Sub UnhookMouse()
If lblnHook Then
Call UnhookWindowsHookEx(llngptrMouseHook)
Set lobjScrollObject = Nothing
llngptrMouseHook = 0
llngptrControlHwnd = 0
lblnHook = False
End If
End Sub
Private Function MouseProc(ByVal pvlngCode As Long, ByVal pvlngptrParam As LongPtr, ByRef prudtParam As MOUSEHOOKSTRUCT) As LongPtr
Dim lngptrHwndUnderCursor As LongPtr
On Error GoTo err_exit
If pvlngCode = HC_ACTION Then
lngptrHwndUnderCursor = WindowFromPoint(prudtParam.pt.X, prudtParam.pt.Y)
If lngptrHwndUnderCursor = llngptrControlHwnd Then
If pvlngptrParam = WM_MOUSEWHEEL Then
If TypeOf lobjScrollObject Is MSForms.ListBox Or TypeOf lobjScrollObject Is MSForms.ComboBox Or _
TypeOf lobjScrollObject Is MSForms.TextBox Then
With lobjScrollObject
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd > 0 Then
If .TopIndex > 0 Then
If .TopIndex > 3 Then
.TopIndex = .TopIndex - 3
Else
.TopIndex = 0
End If
End If
Else
.TopIndex = .TopIndex + 3
End If
Else
If TypeOf lobjScrollObject Is MSForms.ListBox Or TypeOf lobjScrollObject Is MSForms.TextBox Then
If prudtParam.hwnd > 0 Then
Call PostMessageA(llngptrControlHwnd, WM_KEYDOWN, vbKeyLeft, 0)
Else
Call PostMessageA(llngptrControlHwnd, WM_KEYDOWN, vbKeyRight, 0)
End If
End If
End If
End With
ElseIf TypeOf lobjScrollObject Is MSForms.MultiPage Then
With lobjScrollObject.Pages(llngPage)
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd > 0 Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd > 0 Then
If .ScrollLeft > 0 Then
.ScrollLeft = .ScrollLeft - 30
Else
.ScrollLeft = 0
End If
Else
.ScrollLeft = .ScrollLeft + 30
End If
End If
End With
ElseIf TypeOf lobjScrollObject Is MSForms.UserForm Or TypeOf lobjScrollObject Is MSForms.Frame Then
With lobjScrollObject
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd > 0 Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd > 0 Then
If .ScrollLeft > 0 Then
.ScrollLeft = .ScrollLeft - 30
Else
.ScrollLeft = 0
End If
Else
.ScrollLeft = .ScrollLeft + 30
End If
End If
End With
End If
Exit Function
End If
Else
Call UnhookMouse
End If
End If
MouseProc = CallNextHookEx(llngptrMouseHook, pvlngCode, pvlngptrParam, ByVal prudtParam)
Exit Function
err_exit:
Call UnhookMouse
End Function
Gruß
Nepumuk
Anzeige
AW: nur 1x Long (owT)
18.11.2021 15:42:07
Pascal
Hallo ihr beiden
funktionieren nun beide Lösungen. Vielen Dank für die Hilfen!
nun erlaub ich mir noch zu fragen:
was müsste ich wo genau anpassen, damit dieses Scrollen dann auf allen (habe drei) Comboboxen in der UserForm1 funktioniert?
vielen Dank und Grüsse: Pascal
AW: nur 1x Long (owT)
18.11.2021 15:48:30
Nepumuk
Hallo Pascal,
na einfach so:

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call HookMouse(ComboBox1)
End Sub
Private Sub ComboBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call HookMouse(ComboBox2)
End Sub
Private Sub ComboBox3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call HookMouse(ComboBox3)
End Sub
Gruß
Nepumuk
Anzeige
AW: nur 1x Long (owT)
18.11.2021 15:54:04
Pascal
ach so?! - ja natürlich! eigentlich logisch und einfach :-)
danke Euch herzlich und geniesst den Restnachmittag
Pascal

15 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige