ComboBox Scroll with Mouse wheel

[DarkGlobus1OO]

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:

'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!

 

[timecop79]

Can you upload a simplified version of your workbook so I can see... You can use some file sharing site such as Box.net

It's OK tanks

 

[timecop79]

salam bro
here is copy of my workbook, thakns a lot :

FICHE.xlsm

Shared with Dropbox

www.dropbox.com

 

[Jaafar Tribak]

@timecop79

The reason it didn't work for the ListBox is because of the Horizontal Scrollbar that is displayed at the bottom when the Listbox is a multi-column one. The low word and high word values in the lParam needed to be adjusted before sending the WM_LBUTTONDOWN and WM_LBUTTONUP messages.


Download:
FICHE_timecop79.xlsm







Here is the new adapted code that takes into account the presence of an horizontal scrollbar:

In a Standard Module:

Option Explicit

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

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0^
#End If

#If VBA7 Then
    #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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    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
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetQueueStatus Lib "user32" (ByVal fuFlags As Long) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
   
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare 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 Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare 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 Function WaitMessage Lib "user32" () As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, 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 LongPtr, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function GetQueueStatus Lib "user32" (ByVal fuFlags As Long) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#End If

Private Type POINTAPI
  X As Long
  Y As Long
End Type

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

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


Private Const LINES_PER_SCROLL = 1& ' <=== (# OF LINES_PER_SCROLL) :- Change here the # of lines scrolled per mouse-wheel push.

Public sUserFeedBack As String
Private bMonitoringMouseWheel As Boolean
Private bSomeKeyIsBeingPressed As Boolean



Public Property Let EnableMouseScroll( _
    ByVal ListOrComboControl As Object, _
    Optional ByVal ChangeComboValueWithScroll As Boolean, _
    ByVal Enable As Boolean _
)

    Const WM_MOUSEWHEEL = &H20A, WHEEL_DELTA = 120
    Const WM_LBUTTONDOWN = &H201, WM_LBUTTONUP = &H202, MK_LBUTTON = &H1
    Const WM_KEYDOWN = &H100, WM_KEYUP = &H101, VK_ESCAPE = &H1B
    Const PM_NOREMOVE = &H0, PM_NOYIELD = &H2
    Const QS_KEY = &H1, SM_CXVSCROLL = 2

    Static hActualList As LongPtr
    Dim hwnd As LongPtr
   
    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
    Dim lDelta As Integer, lAccumulatedDelta As Long
    Dim l As Long, t As Long, w As Long, h As Long
    Dim XOffset As Long, YOffset As Long
   
   
    Call WindowFromAccessibleObject(ListOrComboControl, hwnd)

    If Not bMonitoringMouseWheel Then
        bMonitoringMouseWheel = True
       
        If Enable Then
           
            'Call UserFeedBack("Start Monitoring MouseWheel Messages for : (" & ListOrComboControl.Name & ")")
            On Error Resume Next
                Application.EnableCancelKey = xlDisabled
                ListOrComboControl.SetFocus
            On Error GoTo 0
           
            Set oiA = ListOrComboControl
            oiA.accLocation l, t, w, h
            l = l + 10&
            t = t + h - (GetSystemMetrics(SM_CXVSCROLL) / 2&) + 1&
            XOffset = (GetSystemMetrics(SM_CXVSCROLL) / 2&)
            If ObjectHasHorizScrollBar(ListOrComboControl, l, t) Then
                YOffset = 3& * ((GetSystemMetrics(SM_CXVSCROLL) / 2&) + 1&)
            Else
                YOffset = (GetSystemMetrics(SM_CXVSCROLL) / 2&) + 1&
            End If
           
            Do While IsWindow(hwnd)

                Call GetCursorPos(tCurPos)
                If IsMouseOverListBox(ListOrComboControl, ChangeComboValueWithScroll, tCurPos, False) = False Then
                    Exit Do
                End If
                   
                #If Win64 Then
                    Dim lPt As LongLong
                    Call 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(ListOrComboControl.Height, False)
                End If
       
                #If Win64 Then
                    Dim lPt2 As LongLong
                    Call CopyMemory(lPt2, tCurPos, LenB(lPt2))
                    hActualList = WindowFromPoint(lPt2)
                #Else
                    hActualList = WindowFromPoint(tCurPos.X, tCurPos.Y)
                #End If
               
                Call WaitMessage
                If PeekMessage(tMsg, NULL_PTR, 0&, 0&, PM_NOREMOVE + PM_NOYIELD) Then
               
                    If GetQueueStatus(QS_KEY) Then
                        bSomeKeyIsBeingPressed = True
                    Else
                        bSomeKeyIsBeingPressed = False
                    End If

                    If tMsg.message = WM_MOUSEWHEEL Then
                        Call GetClientRect(hActualList, tRect)
                       
                        lDelta = HiWord(tMsg.wParam)
                        If lDelta * lAccumulatedDelta > 0& Then
                            lAccumulatedDelta = lAccumulatedDelta + lDelta
                        Else
                            lAccumulatedDelta = lDelta
                        End If
                   
                        #If Win64 Then
                            Dim lParm As LongLong
                            If IsMouseOverListBox(ListOrComboControl, ChangeComboValueWithScroll, tMsg.pt) = True Then
                                If lAccumulatedDelta > 0& Then
                        #Else
                            Dim lParm As Long
                            If IsMouseOverListBox(ListOrComboControl, ChangeComboValueWithScroll, tMsg.pt) = True Then
                                If lAccumulatedDelta > 0& Then
                        #End If
                                    'Call UserFeedBack("MouseWheel Scrolling (Up)")
                                    Low = tRect.Right - XOffset
                                    High = tRect.Top + ((GetSystemMetrics(SM_CXVSCROLL) / 2&) + 1&)
                                Else
4                                   'Call UserFeedBack("MouseWheel Scrolling (Down)")
                                    Low = tRect.Right - XOffset
                                    High = tRect.Bottom - YOffset
                               
                                End If  'End If HighWord
       
                                lParm = MakeDWord(Low, High)
                               
                                For i = 1& To LINES_PER_SCROLL '<=== (LINES_PER_SCROLL):Change this scroll lines Const as required
                                    Call SendMessage(hActualList, WM_LBUTTONDOWN, MK_LBUTTON, ByVal lParm)
                                    Call SendMessage(hActualList, WM_LBUTTONUP, MK_LBUTTON, ByVal lParm)
                                Next i
                               
                                If TypeName(ListOrComboControl.Parent) = "Worksheet" Then SetFocus hActualList
                               
                            End If  'End If IsMouseOverListBox
                    End If  ' End If WM_MOUSEWHEEL
                End If  ' End If PeekMessage
               
                DoEvents
           
            Loop
           
            If TypeName(ListOrComboControl) = "ListBox" Then
                Call PostMessage(GetParent(hActualList), WM_KEYDOWN, VK_ESCAPE, Build_lParam_WM_KEYDOWN(1&, 0&))
                Call PostMessage(GetParent(hActualList), WM_KEYUP, VK_ESCAPE, Build_lParam_WM_KEYUP(1&, 0&))
            End If

            On Error Resume Next
                Application.EnableCancelKey = xlInterrupt
            On Error GoTo 0
            bMonitoringMouseWheel = False
           
            'Call UserFeedBack("Stopped Monitoring MouseWheel Messages for : (" & ListOrComboControl.Name & ")")
           
        End If  'End If Enable
       
    End If 'End If bMonitoringMouseWheel

End Property



'_____________________________________Helper Private Routines_____________________________________________________

Private Function IsMouseOverListBox( _
    ByVal ListOrComboControl As Object, _
    ByVal ChangeComboValueWithScroll As Boolean, _
    ByRef CusPos As POINTAPI, _
    Optional ByVal MouseScrolling As Boolean = True _
) As Boolean

    Dim vChild As Variant, oiA As IAccessible

    #If Win64 Then
         Dim lPt As LongLong
         Call 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 ListOrComboControl Is Nothing And ChangeComboValueWithScroll And oiA.accRole(0&) <> 46& Then
     If bSomeKeyIsBeingPressed = False And MouseScrolling Then
         ListOrComboControl.Value = ListOrComboControl.List(vChild - 1&)
         End If
     End If
     IsMouseOverListBox = oiA.accRole(0&) = 33& Or oiA.accRole(0&) = 46&
   
End Function

Private Function ObjectHasHorizScrollBar(ByVal Ctrl As Object, X As Long, Y As Long) As Boolean
    Dim oiAcc As IAccessible, vKid As Variant
    Set oiAcc = Ctrl
    vKid = oiAcc.accHitTest(X, Y)
    ObjectHasHorizScrollBar = Not CBool(vKid)
End Function

Private Sub UserFeedBack(ByVal Feedback As String)
    Debug.Print Feedback
    sUserFeedBack = 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 HiWord(Param As LongPtr) As Integer
    Call CopyMemory(HiWord, ByVal VarPtr(Param) + 2&, 2&)
End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long

    Const LOGPIXELSX As Long = 88&, LOGPIXELSY As Long = 90&
    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
    Const POINTSPERINCH As Long = 72&
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Private Function Build_lParam( _
    ByVal RepeatCount As Integer, _
    ByVal ScanCode As Byte, _
    ByVal ContextCode As Boolean, _
    Optional ByVal ExtendedKey As Boolean, _
    Optional ByVal PreviousKeyState As Boolean, _
    Optional ByVal TransitionState As Boolean _
) As Long

    Dim lParamBits As Long

    lParamBits = RepeatCount Or (ScanCode) Or 2& ^ 16&
    If ExtendedKey Then lParamBits = lParamBits Or 2& ^ 24&
    If ContextCode Then lParamBits = lParamBits Or 2& ^ 29&
    If PreviousKeyState Then lParamBits = lParamBits Or 2& ^ 30&
    If TransitionState Then lParamBits = lParamBits Or -2& ^ 31&

    Build_lParam = lParamBits

End Function

 
Private Function Build_lParam_WM_KEYDOWN( _
    ByVal RepeatCount As Integer, _
    ByVal ScanCode As Byte, _
    Optional ByVal ExtendedKey As Boolean, _
    Optional ByVal ContextCode As Boolean, _
    Optional ByVal PreviousKeyState As Boolean _
) As Long

    Build_lParam_WM_KEYDOWN = Build_lParam _
                             (RepeatCount, ScanCode, ExtendedKey, ContextCode, PreviousKeyState, False)

End Function
 
 
Private Function Build_lParam_WM_KEYUP( _
    ByVal RepeatCount As Integer, _
    ByVal ScanCode As Byte, _
    Optional ByVal ExtendedKey As Boolean, _
    Optional ByVal ContextCode As Boolean _
) As Long

      Build_lParam_WM_KEYUP = Build_lParam( _
                              RepeatCount, ScanCode, ExtendedKey, ContextCode, True, True)

End Function

 

[timecop79]

Great thanks à lot for all

 

[MyHanhCB]

Hello. I included it in my project, but it seems to only work from the bottom up, but from the top down it doesn't work. Please help.

 

[giri u]

Nevermind. I realised the error appeared because I used both scripts at the same time, and the function names were the same. After renaming one of them the error went away.

Dear Sir
i Have also Same Error Can you help me to Fix That

 

[RobK]

I use the mousewheel solution Titles:

' 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

It simulates a mousekey Down and Up on the scroll bar Up or down key.
This is done with Postmaster with lparam as the passer for X and Y of the mouse.
The Lparam is calculated with MakeDWord. This clearly meant for 32 bits.

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

It malkes a long and not a LongLong . For 64 bits it does not work in my application.
Ik think lparam is a LongLong and should make a Qword so hi and Lo Long to get the x and y coordinate in correctly for 64 Bits.
What happens is a selection of the combobox because It seems that a coordinate within the window out of the scroll Bar area is passed to PostMessage.
It this a right thought or what is wrong.

I tried to makle a MakeQWord

#If Win64 Then
Private Function MakeQWord(ByVal loDword As Long, ByVal hiDword As Long) As LongPtr
Dim hiQword As LongPtr
Dim loQword As LongPtr

hiQword = hiDword
loQword = loDword
MakeQWord = (hiQword * (2 ^ 32)) Or (loQword And &HFFFFFFF)
End Function
#End If

Now the mousescrool does not cause a selection but it scrolls a bit now and then.


Second remark: sometimes a combobox has no scrollbar (not to be set and is determined by system depending on Listrows and actual nr of lines) and then this does not work and it is seen as a selection as you press the mouse on top of an entry area.
I added a check to prevent postmessage when there is no scrollbar: If Low < tRect.Right Then 'Scrollbar visible because GetsystemM<etrics gives back a zero when ther is no scrollbar according to the specs of that call.

Else
Call UserFeedBack("MouseWheel Scrolling (Down)")
Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
High = tRect.Bottom - ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
End If
If Low < tRect.Right Then 'Scrollbar visible
#If Win64 Then
lParm = MakeQWord(Low, High)
#Else
lParm = MakeDWord(Low, High)
#End If
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

Is this a right thing to do or I am wrong.


I could not find an update of the demo excel which soves tghis but maybe someone had the same problem and has solved it. Or my MakeQword is wrong?
Any help is appreciated andf may help others as well.

 

[RobK]

I found several reasons that scroll does not work correctly. It seems not caused by the MakeDword.
If listrows >=listcount or Listrow = 0 then there is no scrollbar and then postmessage gives an 0 as returncode: meaning not succeeded.
This can easily be excluded by an entry check on Listrows versus listcount. In that case leave the mousewheel routine without scrolling as that is not possible without scrollbar.
In case there is a scrollbar I see that Comboboxes which have more than 1 column also get an Not Ok from PostMessage(). Why thát happens I do not know!!!
Has somebody have the same experience with a possible solution!!!