Userform - In Listbox mit Mausrad scrollen und weiteres

[volti]

Liebe Leserin, lieber Leser,
manchmal möchte man in seiner Userform-Listbox gerne mit dem Mausrad bequem scrollen oder vielleicht einen Doppelclick oder Rechtsclick ausführen, um weitere Aktionen zu ermöglichen.

Das ist bei einer Listbox so weit ich weiß nicht vorgesehen.

Das Thema 'Scrollen mit dem Mausrad' wurde hier schon mal behandelt.
https://www.clever-excel-forum.de/Thread...Comboboxen

Damals wurde die Funktionalität über Mousehooking realisiert. Mit der u.a. gezeigten, weniger empfindlichen, Methode benötigt man weniger Code.
Unterschied ist jedoch, dass hier die gewünschte Listbox aktiviert sein muss, während beim Mousehooking das Scrollen bereits beim Überfahren funktioniert.

Hier eine Minimalversion für Listboxscrollen für z.B. zwei Listboxen.
PS: Hat man erst mal Zugang zur Listbox, kann man noch viel mehr machen.....

Code:

' <<<<<<<<< in Modul >>>>>>>>>
Private Declare PtrSafe Function PostMessageA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr

#If Win64 Then
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" _
         Alias "SetWindowLongPtrA" ( _
         ByVal hwnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" ( _
         ByVal hwnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#End If
Private Const GWL_WNDPROC As Long = -4

Private Declare PtrSafe Function CallWindowProcA Lib "user32" ( _
        ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, _
        ByVal Msg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

Dim mlpOldProc As LongPtr

Sub UF_Start(oCtrl As control)
  Dim hWndCtrl As LongPtr
  
  On Error GoTo Fehler
  oCtrl.SetFocus
  hWndCtrl = GetFocus()                     ' Handle holen
  If hWndCtrl <> 0 Then                     ' Listbox hooken
     mlpOldProc = SetWindowLongA(hWndCtrl, GWL_WNDPROC, AddressOf WindowProc)
  End If
Fehler:
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Dim i As Long
  
  Select Case uMsg
  
  Case &H20A ' WM_MOUSEWHEEL
       If hwnd = GetFocus Then
          If wParam > &HFF0000 Then i = 40 Else i = 38
          PostMessageA hwnd, &H100, i, 0 ' WM_KEYDOWN
          PostMessageA hwnd, &H101, i, 0 ' WM_KEYUP
          Exit Function
       End If
  Case &H203, &H205 ' WM_LBUTTONDBLCLK und WM_RBUTTONUP
       MsgBox IIf(uMsg = &H203, "Doppelclick", "Rechtsclick")
    
  End Select
  WindowProc = CallWindowProcA(mlpOldProc, hwnd, uMsg, ByVal wParam, ByVal lParam)
End Function


' <<<<<<<<< ins Userformmodul >>>>>>>>>
Private Sub UserForm_Activate()
  Call UF_Start(Me.ListBox1)
  Call UF_Start(Me.ListBox2)
End Sub

_________
viele Grüße
Karl-Heinz