ComboBox Scroll with Mouse wheel

D

DarkGlobus1OO

New Member
Joined
Sep 28, 2017
Messages
11
i tried to work with peter Peter Thornton (Excel MVP 2008-13) code which works amazing for userform Comboxes and listboxes but im a vba noobie and i cant seem to understand how to make this code work for a regular ComboBox on a worksheet

Module Code:
Code: 
'Enables mouse wheel scrolling in controls
Option Explicit


#If Win64 Then
    Private Type POINTAPI
       XY As LongLong
    End Type
#Else
    Private Type POINTAPI
           X As Long
           Y As Long
    End Type
#End If


Private Type MOUSEHOOKSTRUCT
    Pt As POINTAPI
    hWnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type


#If  VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" _
                                            Alias "FindWindowA" ( _
                                                            ByVal lpClassName As String, _
                                                            ByVal lpWindowName As String) As Long ' not sure if this should be LongPtr
    #If  Win64 Then
        Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
                                            Alias "GetWindowLongPtrA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" _
                                            Alias "GetWindowLongA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #End  If
    Private 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
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr, _
                                                            ByVal nCode As Long, _
                                                            ByVal wParam As LongPtr, _
                                                           lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr) As LongPtr ' MAYBE Long
    'Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
    '                                         Alias "PostMessageA" ( _
    '                                                         ByVal hwnd As LongPtr, _
    '                                                         ByVal wMsg As Long, _
    '                                                         ByVal wParam As LongPtr, _
    '                                                         ByVal lParam As LongPtr) As LongPtr   ' MAYBE Long
    #If  Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal Point As LongLong) As LongPtr    '
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal xPoint As Long, _
                                                            ByVal yPoint As Long) As LongPtr    '
    #End  If
    Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                                            ByRef lpPoint As POINTAPI) As LongPtr   'MAYBE Long
#Else
    Private Declare Function FindWindow Lib "user32" _
                                            Alias "FindWindowA" ( _
                                                            ByVal lpClassName As String, _
                                                            ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowLong Lib "user32.dll" _
                                            Alias "GetWindowLongA" ( _
                                                            ByVal hWnd As Long, _
                                                            ByVal nIndex As Long) As Long
    Private 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
    Private Declare Function CallNextHookEx Lib "user32" ( _
                                                            ByVal hHook As Long, _
                                                            ByVal nCode As Long, _
                                                            ByVal wParam As Long, _
                                                           lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
                                                            ByVal hHook As Long) As Long
    'Private Declare Function PostMessage Lib "user32.dll" _
    '                                         Alias "PostMessageA" ( _
    '                                                         ByVal hwnd As Long, _
    '                                                         ByVal wMsg As Long, _
    '                                                         ByVal wParam As Long, _
    '                                                         ByVal lParam As Long) As Long
    Private Declare Function WindowFromPoint Lib "user32" ( _
                                                            ByVal xPoint As Long, _
                                                            ByVal yPoint As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" ( _
                                                            ByRef lpPoint As POINTAPI) As Long
#End  If


Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
'Private Const WM_KEYDOWN As Long = &H100
'Private Const WM_KEYUP As Long = &H101
'Private Const VK_UP As Long = &H26
'Private Const VK_DOWN As Long = &H28
'Private Const WM_LBUTTONDOWN As Long = &H201
Dim n As Long
Private mCtl As Object
Private mbHook As Boolean
#If  VBA7 Then
    Private mLngMouseHook As LongPtr
    Private mListBoxHwnd As LongPtr
#Else
    Private mLngMouseHook As Long
    Private mListBoxHwnd As Long
#End  If
     
Sub HookListBoxScroll(frm As Object, ctl As Object)
    Dim tPT As POINTAPI
    #If VBA7 Then
        Dim lngAppInst As LongPtr
        Dim hwndUnderCursor As LongPtr
    #Else
        Dim lngAppInst As Long
        Dim hwndUnderCursor As Long
    #End  If
    GetCursorPos tPT
    #If  Win64 Then
        hwndUnderCursor = WindowFromPoint(tPT.XY)
    #Else
        hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
    #End  If
    If TypeOf ctl Is UserForm Then
        If Not frm Is ctl Then
               ctl.SetFocus
        End If
    Else
        If Not frm.ActiveControl Is ctl Then
             ctl.SetFocus
        End If
    End If
    If mListBoxHwnd <> hwndUnderCursor Then
        UnhookListBoxScroll
        Set mCtl = ctl
        mListBoxHwnd = hwndUnderCursor
        #If  Win64 Then
            lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
        #Else
            lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
        #End  If
        ' PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
        If Not mbHook Then
            mLngMouseHook = SetWindowsHookEx( _
                                            WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
            mbHook = mLngMouseHook <> 0
        End If
    End If
End Sub


Sub UnhookListBoxScroll()
    If mbHook Then
        Set mCtl = Nothing
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mListBoxHwnd = 0
        mbHook = False
    End If
End Sub
#If  VBA7 Then
    Private Function MouseProc( _
                            ByVal nCode As Long, ByVal wParam As Long, _
                            ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
        Dim idx As Long
        On Error GoTo errH
        If (nCode = HC_ACTION) Then
            #If  Win64 Then
                If WindowFromPoint(lParam.Pt.XY) = mListBoxHwnd Then
                    If wParam = WM_MOUSEWHEEL Then
                        MouseProc = True
'                        If lParam.hWnd > 0 Then
'                            postMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
'                        Else
'                            postMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
'                        End If
'                        postMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                             If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                             idx = idx + mCtl.ListIndex
                             If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                        End If
                    Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #Else
                If WindowFromPoint(lParam.Pt.X, lParam.Pt.Y) = mListBoxHwnd Then
                    If wParam = WM_MOUSEWHEEL Then
                        MouseProc = True
'                        If lParam.hWnd > 0 Then
'                            postMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
'                        Else
'                            postMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
'                        End If
'                        postMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                             If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                             idx = idx + mCtl.ListIndex
                             If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                        End If
                        Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #End If
        End If
        MouseProc = CallNextHookEx( _
                                mLngMouseHook, nCode, wParam, ByVal lParam)
        Exit Function
errH:
        UnhookListBoxScroll
    End Function
#Else
    Private Function MouseProc( _
                            ByVal nCode As Long, ByVal wParam As Long, _
                            ByRef lParam As MOUSEHOOKSTRUCT) As Long
        Dim idx As Long
        On Error GoTo errH
        If (nCode = HC_ACTION) Then
            If WindowFromPoint(lParam.Pt.X, lParam.Pt.Y) = mListBoxHwnd Then
                If wParam = WM_MOUSEWHEEL Then
                    MouseProc = True
'                    If lParam.hWnd > 0 Then
'                    postMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
'                    Else
'                    postMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
'                    End If
'                    postMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                    
                    If TypeOf mCtl Is Frame Then
                        If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                        idx = idx + mCtl.ScrollTop
                        If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                            mCtl.ScrollTop = idx
                        End If
                    ElseIf TypeOf mCtl Is UserForm Then
                        If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                        idx = idx + mCtl.ScrollTop
                        If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                            mCtl.ScrollTop = idx
                        End If
                    Else
                         If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                         idx = idx + mCtl.ListIndex
                         If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                    End If
                    Exit Function
                End If
            Else
                UnhookListBoxScroll
            End If
        End If
        MouseProc = CallNextHookEx( _
        mLngMouseHook, nCode, wParam, ByVal lParam)
        Exit Function
errH:
        UnhookListBoxScroll
    End Function
#End  If


hope someone here can help me i have been scratching my head around this problem for days!
:confused::confused::confused::confused:
 
Last edited by a moderator:
Sort by date Sort by votes
Hello @Jaafar Tribak ,

So I found out bug with API code for listbox on userform Modeless.
If you press ESC when your mouse is over listbox you get "Code execution has been interrupted" error (happens 80% of the time).
Debug is on this line : "If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then".
What I think is happening it tries to Declare "WaitMessage", but gets interrupted by excels esc command.
Would love to know if there is work around was going to use ESC for closing userform (I have small userform with listbox and labes as template picer).
I tried to catch the ESC button press in listbox events, but no luck the API code runs before any listbox events. I dont have knowledge about Declare Functions.
 
Upvote 0

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Greetings Jaafar, :)

My turn to thank you for your wonderful work and to ask another favor of you.

I was originally using coding from Peter Thornton to scroll comboboxes with the mouse wheel. It worked well functionally but was a bit unstable (crashing and/or scrolling the incorrect combobox). I switched to your code (post #49 in this thread). It is stable!!! It works beautifully and unlike most of the other solutions I have seen, the highlight in the drop down list scrolls with the mouse! Wonderful as it is clearer to the user where the current selection will be.

One thing that Peter Thorton's code did that I have not seen anywhere yet is that scrolling the mouse wheel actually scrolled the values (not just hilighting them). I'd love it if it were possible to add this functionality with the method you use to scroll the list. My application is this:

I have comboboxes populated with colors (long values stored in a hidden 2nd column). There are comboboxes for background color, text color and border color. My code currently is in the combobox_change event updates a label. Very simple code, like this:

VBA Code: 
Private Sub cbBackgroundColor_Change()
    lCommentSample.BackColor = cbBackgroundColor.Column(1)
End Sub
  • When I was using Peter's code, the change event was being triggered AS I SCROLLED. So without having to mouse click, I could see the color update the label in real time. Then when I saw the color I wanted, I could click to close the combobox and remain with the desired color selected. That is, a single mouse click resulted in the desired color.
  • With the current code set (from post #49 in this thread), I must manually click each color to see the label updated. Then I must click the drop down button again to reopen the list, click a color. Repeat. Repeat. Repeat. Until I find the combination I want. Potentially tens of clicks to get the color desired.
I thought that since the list value is being hilighted as the list is scrolled, this should be easily possible. Sadly, my knowledge of the API is (very poor) and I was unable to figure this out on my own. Is it possible to have the mouse scroll trap and send the currently highlighted list value?
 
Upvote 0
tbrock said:
One thing that Peter Thorton's code did that I have not seen anywhere yet is that scrolling the mouse wheel actually scrolled the values (not just hilighting them). I'd love it if it were possible to add this functionality with the method you use to scroll the list.
Click to expand...

I have added this Optional boolean argument (ChangeComboValueWithScroll) to the EnableMouseScroll Property which when set to TRUE, it will make the combobox value change to reflect the current highlighted item while mousewheel-scrolling ... See Gif image below:

You proceed like this:
EnableMouseScroll(ComboBox:=ComboBox1, ChangeComboValueWithScroll:=True) = True
If this optional argument is set to FALSE or is simply omitted, the value of the combobox won't change when mousewheel-scrolling.

workbook demo






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

' Jaafar Tribak @ MrExcel.com on 22/04/20 (updated on 18/08/2020)
' 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(ComboBox:=ComboBox1, ChangeComboValueWithScroll:=True) = 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, Optional ByVal ChangeComboValueWithScroll As Boolean, 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 & ")")
           
            Application.EnableCancelKey = xlDisabled

            Do While IsWindow(hwnd)
                GetCursorPos tCurPos
                If IsMouseOverListBox(ComboBox, ChangeComboValueWithScroll, 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(ComboBox, ChangeComboValueWithScroll, tMsg.pt) = True Then
                            If HighWord64(tMsg.wParam) = WHEEL_DELTA Then
                    #Else
                        Dim lParm As Long
                        If IsMouseOverListBox(ComboBox, ChangeComboValueWithScroll, 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
           
            Application.EnableCancelKey = xlInterrupt
           
            bMonitoringMouseWheel = False
            Call UserFeedBack("MouseWheel Monitoring Stopped.")
        End If
    End If

End Property


Private Function IsMouseOverListBox(ByVal ComboBox As Object, ByVal ChangeComboValueWithScroll As Boolean, 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
        If Not ComboBox Is Nothing And ChangeComboValueWithScroll And oIA.accRole(0&) <> 46 Then
            ComboBox.Value = ComboBox.List(vChild - 1)
        End If
        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- Cose Usage in the UserForm Module:
VBA Code: 
Option Explicit

Private Sub UserForm_Initialize()

    Dim i As Long
   
    'Populate the 2 comboboxes.
    For i = 1 To 1000
        Me.ComboBox1.AddItem i
        Me.ComboBox2.AddItem i
    Next i
   
    'set their initial values
    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)
    'Change the combobox value when scrolling by setting the second Optional arg to TRUE.
    EnableMouseScroll(ComboBox:=ComboBox1, ChangeComboValueWithScroll:=True) = 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(ComboBox:=ComboBox2) = True
    lblFeedBack.Caption = sFeedback
End Sub

Private Sub CommandButton1_Click()
    Unload Me
End Sub
 
Upvote 0
I tried to use this code and it gave me Compile Error, Expected: Expression, Image attached.
 

Attachments

  • expression.png
    expression.png
    11.2 KB · Views: 93
Upvote 0
DarkJester89 said:
I tried to use this code and it gave me Compile Error, Expected: Expression, Image attached.
Click to expand...
Could you post the entire lines? That looks like coding meant for a web browser as opposed to vba code?

I do not have "URL" or "hash" anywhere in my code. I am awfully forgetful, but I do not believe I had (and removed) such code either.
 
Upvote 0
It's an artefact from the old board software. I think I have cleaned up most of the posts now.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
253
Jaafar Tribak
Jaafar Tribak
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
483
Jaafar Tribak
Jaafar Tribak
D
  • Solved
Long vs Longptr
Replies
7
Views
329
Micron
M
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
790
Jaafar Tribak
Jaafar Tribak
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
328
Minh Tuan VN
M

Forum statistics

Threads
1,223,891
Messages
6,175,229
Members
452,621
Latest member
Laura_PinksBTHFT

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