Scroll when inside "dropdown area" of combobox, not just main object - userform

D

dooniem

New Member
Joined
Apr 22, 2020
Messages
7
Office Version
  1. 365
Platform
  1. Windows
I have found much help in this forum but I'm lacking the last dot of the "i".
I've come across 2 different approaches to getting mousewheel scroll inside a userform. Both written by @Jaafar Tribak
These are:
[Alt.1] – Scroll any control
[Alt.2] – Scroll ListBoxes

With [Alt.1] scrolling inside ComboBoxes only works when the mouse pointer is inside the ComboBox's original dimensions. Not inside the dropdown area.
With [Alt.2] scrolling only works with ListBoxes, but I mention this because the code seems more "lighter", and it let's me specify which control to enable instead of looping them all.

Question:
Could you guys help me get to also work with ComboBoxes, and work when the mouse cursor is inside the dropdown area of the combobox?
combobox-png.12055


I figure I would have to include the dropdown height to the combobox objects height once the ComboBox is expanded.
My best idea would be to multiply the .ListRow.value of the listbox with 10 to get the expanded height, but for those of you more familiar with the "API handles", maybe this is an easy value to find?

And I guess the line
VBA Code: 
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    EnableMouseScroll(ComboBox1) = True
End Sub
Should/could be changed to _MouseDown instead of _MouseMove on ComboBoxes to trigger the scroll check.

But I struggle to untangle all the API commands and debug why [Alt.2] is not working for ComboBox objects.
It's probably easier getting [Alt1] to work with a larger "hitbox" when the ComboBox is expanded...But any thoughts and help is much appreciated on solving this.
 

Attachments

  • combobox.png
    combobox.png
    11.7 KB · Views: 822

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Sort by date Sort by votes
Heh, question is:
Could you guys help me get [Alt.2] to also work with ComboBoxes, and work when the mouse cursor is inside the dropdown area of the combobox?
 
Upvote 0
Hi dooniem

Workbook Demo.

Try this code :

1- API code in a Standard Module :
VBA Code: 
Option Explicit

' Jaafar Tribak @ MrExcel.com on 22/04/20
' Code that enables mousewheel scrolling in vba Userform ComboBoxes.

' USAGE:
' ------
'  Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
'      EnableMouseScroll(ComboBox1) = True
'  End Sub


Private Type POINTAPI
  x As Long
  y As Long
End Type

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


#If VBA7 Then

    Private Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type

    #If Win64 Then
       Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    #Else
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If

    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long

#Else

    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type

    Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal Wparam As Long, ByVal lParam As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long

#End If


' API consts
Private Const WM_MOUSEWHEEL = &H20A
Private Const WHEEL_DELTA = 120
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const MK_LBUTTON = &H1
Private Const SM_CXVSCROLL = 2
Private Const PM_NOREMOVE = &H0
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTSPERINCH As Long = 72

Private Const LINES_PER_SCROLL = 1 '<=== (LINES_PER_SCROLL):Change scroll lines value as required

Private bMonitoringMouseWheel As Boolean
Public sFeedback As String



Public Property Let EnableMouseScroll(ByVal ComboBox As Object, ByVal Enable As Boolean)

    #If VBA7 Then
        Static DropDownHwnd As LongPtr
        Dim hwnd As LongPtr
    #Else
        Static DropDownHwnd As Long
        Dim hwnd As Long
    #End If
    
    Dim tRect As RECT, tMsg As MSG, tCurPos As POINTAPI
    Dim Low As Integer, High As Integer, i As Integer
    Dim vChild As Variant, oIA As IAccessible


    ComboBox.SetFocus
    WindowFromAccessibleObject ComboBox, hwnd

    If Not bMonitoringMouseWheel Then
        bMonitoringMouseWheel = True
        
        If Enable Then
            Call UserFeedBack("Monitoring MouseWheel Messages for : (" & ComboBox.Name & ")")
            
            Do While IsWindow(hwnd)
                GetCursorPos tCurPos
                If IsMouseOverListBox(tCurPos) = False Then
                    Exit Do
                End If
                    
                #If Win64 Then
                    Dim lPt As LongPtr
                    CopyMemory lPt, tCurPos, LenB(lPt)
                    Call AccessibleObjectFromPoint(lPt, oIA, vChild)
                #Else
                    Call AccessibleObjectFromPoint(tCurPos.x, tCurPos.y, oIA, vChild)
                #End If
        
                If oIA.accRole(0&) = 46 Then
                    tCurPos.y = tCurPos.y + PTtoPX(ComboBox.Height, False)
                End If
        
                #If Win64 Then
                    Dim lPt2 As LongPtr
                    CopyMemory lPt2, tCurPos, LenB(lPt2)
                    DropDownHwnd = WindowFromPoint(lPt2)
                #Else
                    DropDownHwnd = WindowFromPoint(tCurPos.x, tCurPos.y)
                #End If
                
                WaitMessage
                If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
                    GetClientRect DropDownHwnd, tRect
                    #If Win64 Then
                        Dim lParm As LongPtr
                        If IsMouseOverListBox(tMsg.pt) = True Then
                            If HighWord64(tMsg.wParam) = WHEEL_DELTA Then
                    #Else
                        Dim lParm As Long
                        If IsMouseOverListBox(tMsg.pt) = True Then
                            If HighWord32(tMsg.wParam) = WHEEL_DELTA Then
                    #End If
                                Call UserFeedBack("MouseWheel Scrolling (Up)")
                                Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
                                High = tRect.Top + ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
                            Else
                                Call UserFeedBack("MouseWheel Scrolling (Down)")
                                Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
                                High = tRect.Bottom - ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
                            End If
                            lParm = MakeDWord(Low, High)
                            For i = 1 To LINES_PER_SCROLL '<=== (LINES_PER_SCROLL):Change this scroll lines Const as required
                                PostMessage DropDownHwnd, WM_LBUTTONDOWN, MK_LBUTTON, lParm
                                PostMessage DropDownHwnd, WM_LBUTTONUP, MK_LBUTTON, lParm
                            Next i
                            
                        End If
                        
                End If  ' PeekMessage
                DoEvents
            Loop
            bMonitoringMouseWheel = False
            Call UserFeedBack("MouseWheel Monitoring Stopped.")
        End If
    End If

End Property


Private Function IsMouseOverListBox(ByRef CusPos As POINTAPI) As Boolean
      Dim vChild As Variant, oIA As IAccessible

       #If Win64 Then
            Dim lPt As LongPtr
            CopyMemory lPt, CusPos, LenB(lPt)
            Call AccessibleObjectFromPoint(lPt, oIA, vChild)
        #Else
              Call AccessibleObjectFromPoint(CusPos.x, CusPos.y, oIA, vChild)
        #End If

        On Error Resume Next
        IsMouseOverListBox = oIA.accRole(0&) = 33 Or oIA.accRole(0&) = 46
End Function

Private Sub UserFeedBack(ByVal Feedback As String)
    Debug.Print Feedback
    sFeedback = Feedback
End Sub

Private Function MakeDWord(ByVal loword As Integer, ByVal hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function

Private Function HighWord32(ByVal wParam As Long) As Integer
    CopyMemory HighWord32, ByVal VarPtr(wParam) + 2, 2
End Function

#If Win64 Then
    Private Function HighWord64(ByVal wParam As LongPtr) As Long
        CopyMemory HighWord64, ByVal VarPtr(wParam) + 2, 4
    End Function
#End If

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Static lDPI(1), hDc

    If lDPI(0) = 0 Then
        hDc = GetDC(0)
        lDPI(0) = GetDeviceCaps(hDc, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hDc, LOGPIXELSY)
        hDc = ReleaseDC(0, hDc)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function




2- CODE USAGE EXAMPLE in the UserForm Module (applied to ComboBox1 and ComboBox2)
VBA Code: 
Option Explicit


Private Sub UserForm_Initialize()

    Dim i As Long
    
    For i = 1 To 1000
        Me.ComboBox1.AddItem i
        Me.ComboBox1.AddItem Chr(WorksheetFunction.RandBetween(32, 126))
        
        Me.ComboBox2.AddItem i
        Me.ComboBox2.AddItem Chr(WorksheetFunction.RandBetween(32, 126))
    Next i
    
    Me.ComboBox1.ListIndex = 10
    Me.ComboBox2.ListIndex = 2

End Sub


Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    EnableMouseScroll(ComboBox1) = True
    lblFeedBack.Caption = sFeedback
End Sub


Private Sub ComboBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    EnableMouseScroll(ComboBox2) = True
    lblFeedBack.Caption = sFeedback
End Sub

Private Sub CommandButton1_Click()
    Unload Me
End Sub
 
Upvote 0
Amazing! Very impressive work on so short notice. Can't thank you enough.
Tested and works for both my listboxes and comboboxes!
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
787
huiettcm
H
C
  • Question Question
Excel VBA- Viewing and Updating existing worksheet data with Excel UserForm with Dependent Comboboxes
Replies
2
Views
1K
charliechaz
C
B
  • Question Question
Scroll ComboBox in Userform in Excel 365
Replies
0
Views
1K
bsweet0us
B
A
  • Solved
Calendar issue
Replies
1
Views
2K
AndyEd
A

Forum statistics

Threads
1,224,820
Messages
6,181,154
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top