none
Mouse scroll in UserForm ListBox in Excel 2010 RRS feed

  • Question

  • Hello,

    How do I enable mouse scroll in listbox inside a userform (I am using Excel 2010 & windows 7).

    Thanks,


    Guy Zommer

    Thursday, July 19, 2012 4:39 AM

Answers

All replies

  • This requires Windows API calls. See http://www.xtremevbtalk.com/showthread.php?p=812821#post798072

    Regards, Hans Vogelaar

    Thursday, July 19, 2012 4:51 AM
  • Thanks for the answer but I already tried this answer and it does not work.


    Guy Zommer

    Thursday, July 19, 2012 4:55 AM
  • I am using windows 7

    Guy Zommer

    Thursday, July 19, 2012 4:56 AM
  • Do you happen to be using 64-bit Office 2010 on 64-bit Windows 7?

    Regards, Hans Vogelaar

    Thursday, July 19, 2012 5:26 AM
  • No I am using 32 bit

    Guy Zommer

    Thursday, July 19, 2012 5:28 AM
  • Sorry about that, it doesn't work for me either. I'm afraid I have no idea how to make it work.


    Regards, Hans Vogelaar

    Thursday, July 19, 2012 5:35 AM
  • This requires Windows API calls. See http://www.xtremevbtalk.com/showthread.php?p=812821#post798072

    There are a couple of things wrong, in the normal module change

    Dim MyForm As UserForm
    to
    Dim MyForm As UserForm1 (or the name of the form)

    and change
    GROUPSDLG.MouseWheel Rotation
    to
    MyForm.MouseWheel Rotation  As written with the above changes mouse scroll should work but probably even if the mouse is not directly over the Listbox, or even when the mouse is not over the form. Most userform controls are 'windowless', ie without a handle, though the Listbox does have one (albeit not one that can be uniquely determined if the form has multiple listboxes or combos). But if assuming only one listbox on the form could return it's handle and then only call the scroll code if the mouse is over the listbox. If interested try including the following

    ' in the declarations area
    Private Type POINTAPI
         x As Long
         y As Long
    End Type
    
    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
    
    Function WindowUnderMouse() As Long
    Dim tPT As POINTAPI
         Call GetCursorPos(tPT)
         WindowUnderMouse = WindowFromPoint(tPT.x, tPT.y)
    End Function
    
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
                                 ByVal hWnd1 As Long, ByVal hwnd2 As Long, _
                                 ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    
    ' in function WindowProc
    If Lmsg = WM_MOUSEWHEEL Then
    
    If WindowUnderMouse = LocalHwnd Then
         MouseKeys = wParam And 65535
         Rotation = wParam / 65536
         'My Form    MouseWheel function
         MyForm.MouseWheel Rotation
    End If
    End If
    
    ' in Sub WheelHook
    dim hForm as long, hCtrl as long
    hForm = FindWindow("ThunderDFrame", MyForm.Caption)
    hCtrl = FindWindowEx(hForm , 0&, "F3 Server 60000000", vbNullString)
    LocalHwnd = FindWindowEx(hCtrl, 0&, "F3 Server 60000000", vbNullString)

    Can't overstress enough how careful need to be with subclassing and hooks like this in VBA. Any unhandled errors or 'breaking' the code will crash Excel.  I'm a bit rusty on this type of stuff but I suspect there might be a slightly safer way of doing this. Anyway, in a light test it all seems to work

    Peter Thornton

    Thursday, July 19, 2012 10:32 AM
    Moderator
  • Thanks but it is not working

    Guy Zommer

    Thursday, July 19, 2012 11:12 AM
  • Try changing
    "F3 Server 60000000"
    to
    "F3 Server 5a940000"

    If still not working explain what you have done. Clarify if you have tested with the first set of corrections to the original code I mentioned, before going on to try the extra stuff I suggested.  Have you debugged return values to the various window handles and SetWindowLong, ie LocalPrevWndProc. Also be sure to test first with only one Listbox on the form.

    FWIW I've tested in XP & W7, and 2003, 2007 & 2010 and all working. That said I'd probably make further changes for real use.

    Peter Thornton

    Thursday, July 19, 2012 12:02 PM
    Moderator
  • The code with the corrections and suggestions should work, however I've ahad another look and I thnk something like the following would be safer, partly because the hook should normaly only be running while the mouse is over the Listbox. Also no need to cater for the different ListBox window classname in different versions.

    Add a ListBox to a form, code in form and normal modules as indicated.

    ''''' Userform code
    Private Sub ListBox1_Change()
    ' be sure to include Error handling for any code that
    ' might get called while the hook is running
         On Error GoTo errExit
         Me.Caption = Me.ListBox1.Value
         Exit Sub
    errExit:
    End Sub
    
    Private Sub ListBox1_MouseMove( _
                 ByVal Button As Integer, ByVal Shift As Integer, _
                 ByVal x As Single, ByVal y As Single)
    ' start tthe hook
         HookListBoxScroll
    End Sub
    
    Private Sub UserForm_Initialize()
    Dim i As Long
    Dim s As String
         s = "this is line "
         For i = 1 To 50
                 Me.ListBox1.AddItem s & i
         Next
    End Sub
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
         UnhookListBoxScroll
    End Sub
    ''''''' end Userform code
    
    ''''''' normal module code
    
    Option Explicit
    
    Private Type POINTAPI
         x As Long
         y As Long
    End Type
    
    Private Type MOUSEHOOKSTRUCT
         pt As POINTAPI
         hwnd As Long
         wHitTestCode As Long
         dwExtraInfo As Long
    End Type
    
    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
    
    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
    
    Private mLngMouseHook As Long
    Private mListBoxHwnd As Long
    Private mbHook As Boolean
    
    Sub HookListBoxScroll()
    Dim lngAppInst As Long
    Dim hwndUnderCursor As Long
    Dim tPT As POINTAPI
            GetCursorPos tPT
            hwndUnderCursor = WindowFromPoint(tPT.x, tPT.y)
            If mListBoxHwnd <> hwndUnderCursor Then
                 UnhookListBoxScroll
                 mListBoxHwnd = hwndUnderCursor
                    lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
                    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
                 UnhookWindowsHookEx mLngMouseHook
                 mLngMouseHook = 0
                 mListBoxHwnd = 0
                 mbHook = False
         End If
    End Sub
    
    Private Function MouseProc( _
                 ByVal nCode As Long, ByVal wParam As Long, _
                 ByRef lParam As MOUSEHOOKSTRUCT) As Long
            On Error GoTo errH 'Resume Next
            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
                                 Exit Function
                         End If
                 Else
                         UnhookListBoxScroll
                 End If
         End If
            MouseProc = CallNextHookEx( _
                                 mLngMouseHook, nCode, wParam, ByVal lParam)
         Exit Function
    errH:
            UnhookListBoxScroll
    End Function

    As written the PostMessage API is used to change the Listindex, however with a reference to the form or listbox control could change the .ListIndex and/or .TopIndex directly, in one or more 'units' as required.

    I haven't tested but it should work as-is for multiple ListBox's.

    The API code would need adapting for use in Office-64

    Peter Thornton

    • Proposed as answer by AmiMerlin Monday, February 24, 2014 11:13 PM
    Thursday, July 19, 2012 4:54 PM
    Moderator
  • > I haven't tested but it should work as-is for multiple ListBox's.

    I have now, and for multiple ListBox's best to ensure the Listbox to be 'scrolled' is the 'active control', which can be simply done like this -

    ' replace the Listbox mouse move event in the original example with this
    Private Sub ListBox1_MouseMove( _
                 ByVal Button As Integer, ByVal Shift As Integer, _
                 ByVal X As Single, ByVal Y As Single)
            If Not Me.ActiveControl Is Me.ListBox1 Then
                 Me.ListBox1.SetFocus
         End If
         HookListBoxScroll
    End Sub

    It might be worth doing that even if only one Listbox. However, if using the "change .ListIndex and/or .TopIndex directly" approach, rather than the PostMessage API, it's not necessary for the control to be active.

    Peter Thornton

    Friday, July 20, 2012 11:08 AM
    Moderator
  • Thanks it is working!


    Guy Zommer

    • Marked as answer by Guy Zommer Sunday, July 22, 2012 5:11 AM
    Sunday, July 22, 2012 5:11 AM
  • I take it you mean the new approach I posted is working, right?. Did you also manage to get the original approach with the corrections as suggested working.

    Peter Thornton

    Sunday, July 22, 2012 1:01 PM
    Moderator
  • Yes thank you again!


    Guy Zommer

    Sunday, July 22, 2012 1:03 PM
  • In effect I asked "did A or B work for you, or both" and you replied simply "yes"!

    The reason for asking is I am interested to know which approach worked for you, and if one didn't why not. It might mean something simple was overlooked while implementing the code (eg all the corrections I suggested were not included), or it might mean the approach is unreliable in some systems and best avoided.

    Peter Thornton

    Monday, July 23, 2012 8:52 AM
    Moderator
  • Hi,

    The code from Thursday, July 19, 2012 4:54 PM worked for me.


    Guy Zommer

    Tuesday, July 24, 2012 7:44 AM
  • Hello again,

    One more question, How can I implement it for Combo Box?

    Thanks,


    Guy Zommer

    Tuesday, July 31, 2012 12:53 PM
  • Which code are you using, I have tried to ask you a few times but your response about the code on a certain date was not helpful. All the code I posted was on 19 July but I didn't post anything at 4:54pm, at least not in my time zone.

    Please clearly explain which code worked for you and which code, if any doesn't work. If the first code, which you found yourself didn't work did you also try the corrections I suggested.

    I also need to know which code to adapt for the combobox

    Peter Thornton

    Tuesday, July 31, 2012 4:24 PM
    Moderator
  • Thanks for your kind help, I  am sorry if I didn't explain my self.

    The code that is working for me is:

    1. In the module level:

    Private Type POINTAPI
         X As Long
         Y As Long
    End Type

    Private Type MOUSEHOOKSTRUCT
         pt As POINTAPI
         hwnd As Long
         wHitTestCode As Long
         dwExtraInfo As Long
    End Type

    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

    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

    Private mLngMouseHook As Long
    Private mListBoxHwnd As Long
    Private mbHook As Boolean

    Sub HookListBoxScroll()
    Dim lngAppInst As Long
    Dim hwndUnderCursor As Long
    Dim tPT As POINTAPI
            GetCursorPos tPT
            hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
            If mListBoxHwnd <> hwndUnderCursor Then
                 UnhookListBoxScroll
                 mListBoxHwnd = hwndUnderCursor
                    lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
                    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
                 UnhookWindowsHookEx mLngMouseHook
                 mLngMouseHook = 0
                 mListBoxHwnd = 0
                 mbHook = False
         End If
    End Sub

    Private Function MouseProc( _
                 ByVal nCode As Long, ByVal wParam As Long, _
                 ByRef lParam As MOUSEHOOKSTRUCT) As Long
            On Error GoTo errH 'Resume Next
            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
                                 Exit Function
                         End If
                 Else
                         UnhookListBoxScroll
                 End If
         End If
            MouseProc = CallNextHookEx( _
                                 mLngMouseHook, nCode, wParam, ByVal lParam)
         Exit Function
    errH:
            UnhookListBoxScroll
    End Function

     2. In UserForm

    Private Sub ListBox1_MouseMove( _
               ByVal Button As Integer, ByVal Shift As Integer, _
               ByVal X As Single, ByVal Y As Single)
        HookListBoxScroll
    'End Sub


    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        UnhookListBoxScroll
    End Sub
    '*********************************************'''''' end Userform code

     I want to implement the scroll mouse also in combobox.

    Thanks in advance,


    Guy Zommer

    Wednesday, August 1, 2012 3:56 AM
  • Thanks for your kind help, I  am sorry if I didn't explain my self.

    The code that is working for me is:

    1. In the module level:

    Private Type POINTAPI
         X As Long
         Y As Long
    End Type

    Private Type MOUSEHOOKSTRUCT
         pt As POINTAPI
         hwnd As Long
         wHitTestCode As Long
         dwExtraInfo As Long
    End Type

    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

    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

    Private mLngMouseHook As Long
    Private mListBoxHwnd As Long
    Private mbHook As Boolean

    Sub HookListBoxScroll()
    Dim lngAppInst As Long
    Dim hwndUnderCursor As Long
    Dim tPT As POINTAPI
            GetCursorPos tPT
            hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
            If mListBoxHwnd <> hwndUnderCursor Then
                 UnhookListBoxScroll
                 mListBoxHwnd = hwndUnderCursor
                    lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
                    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
                 UnhookWindowsHookEx mLngMouseHook
                 mLngMouseHook = 0
                 mListBoxHwnd = 0
                 mbHook = False
         End If
    End Sub

    Private Function MouseProc( _
                 ByVal nCode As Long, ByVal wParam As Long, _
                 ByRef lParam As MOUSEHOOKSTRUCT) As Long
            On Error GoTo errH 'Resume Next
            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
                                 Exit Function
                         End If
                 Else
                         UnhookListBoxScroll
                 End If
         End If
            MouseProc = CallNextHookEx( _
                                 mLngMouseHook, nCode, wParam, ByVal lParam)
         Exit Function
    errH:
            UnhookListBoxScroll
    End Function

     2. In UserForm

    Private Sub ListBox1_MouseMove( _
               ByVal Button As Integer, ByVal Shift As Integer, _
               ByVal X As Single, ByVal Y As Single)
        HookListBoxScroll
    'End Sub


    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        UnhookListBoxScroll
    End Sub
    '*********************************************'''''' end Userform code

     I want to implement the scroll mouse also in combobox.

    Thanks in advance,


    Guy Zommer

    Wednesday, August 1, 2012 3:56 AM
  • OK, now I know which code worked for you. Could you also clarify if you tried the code you found, which as written didn't work, but with the corrections I suggested.

    The following should scroll both ComboBox and ListBox controls with the mouse wheel.

    Put one ComboBox and two ListBox's on a form. Paste the following into the Userform module and a Normal module as indicated

    '''''' normal module code
    
    Option Explicit
    
    Private Type POINTAPI
            X As Long
            Y As Long
    End Type
    
    Private Type MOUSEHOOKSTRUCT
            pt As POINTAPI
            hwnd As Long
            wHitTestCode As Long
            dwExtraInfo As Long
    End Type
    
    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
    
    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
    
    Private mLngMouseHook As Long
    Private mListBoxHwnd As Long
    Private mbHook As Boolean
    Private mCtl As MSForms.Control
    Dim n As Long
    
    Sub HookListBoxScroll(frm As Object, ctl As MSForms.Control)
    Dim lngAppInst As Long
    Dim hwndUnderCursor As Long
    Dim tPT As POINTAPI
         GetCursorPos tPT
         hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
         If Not frm.ActiveControl Is ctl Then
                 ctl.SetFocus
         End If
         If mListBoxHwnd <> hwndUnderCursor Then
                 UnhookListBoxScroll
                 Set mCtl = ctl
                 mListBoxHwnd = hwndUnderCursor
                 lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
                 ' 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
    
    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 lParam.hwnd > 0 Then idx = -1 Else idx = 1
                                 idx = idx + mCtl.ListIndex
                                 If idx >= 0 Then mCtl.ListIndex = idx
                                    Exit Function
                         End If
                 Else
                         UnhookListBoxScroll
                 End If
         End If
         MouseProc = CallNextHookEx( _
                                 mLngMouseHook, nCode, wParam, ByVal lParam)
         Exit Function
    errH:
         UnhookListBoxScroll
    End Function
    '''''''' end normal module code
    
    'http://social.Msdn.microsoft.com/Forums/en-US/isvvba/thread/7d584120-a929-4e7c-9ec2-9998ac639bea#7738fb96-12be-4e3c-af5c-abaae64a5e94
    '
    '19-Jul-2012
    
    ''''' Userform code
    Private Sub comboBox1_MouseMove( _
                            ByVal Button As Integer, ByVal Shift As Integer, _
                            ByVal X As Single, ByVal Y As Single)
                    HookListBoxScroll Me, Me.ComboBox1
    End Sub
    
    Private Sub ListBox1_MouseMove( _
                            ByVal Button As Integer, ByVal Shift As Integer, _
                            ByVal X As Single, ByVal Y As Single)
             HookListBoxScroll Me, Me.ListBox1
    End Sub
    
    Private Sub ListBox2_MouseMove( _
                            ByVal Button As Integer, ByVal Shift As Integer, _
                            ByVal X As Single, ByVal Y As Single)
             HookListBoxScroll Me, Me.ListBox2
    End Sub
    Private Sub UserForm_Initialize()
    Dim i As Long
    Dim s As String
            s = "this is line "
            For i = 1 To 50
                            Me.ComboBox1.AddItem s & i
                            Me.ListBox1.AddItem s & i
                            Me.ListBox2.AddItem s & i
            Next
    End Sub
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
            UnhookListBoxScroll
    End Sub
    ''''''' end Userform code
    

    You can delete the commented PostMessage code

    Peter Thornton

    • Proposed as answer by AmiMerlin Monday, February 24, 2014 11:13 PM
    Wednesday, August 1, 2012 2:50 PM
    Moderator
  • Thanks a lot it is working good.

    Regarding the your question "code you found, which as written didn't work, but with the corrections I suggested" I didn't try it.


    Guy Zommer

    Sunday, August 5, 2012 4:22 AM
  • Glad it worked and thanks for the feedback.

    Peter Thornton

    Monday, August 6, 2012 10:05 AM
    Moderator
  • OK, now I know which code worked for you. Could you also clarify if you tried the code you found, which as written didn't work, but with the corrections I suggested.

    The following should scroll both ComboBox and ListBox controls with the mouse wheel.

    Put one ComboBox and two ListBox's on a form. Paste the following into the Userform module and a Normal module as indicated

    <span style="color:green">'''''' normal module code</span>
    
    <span style="color:blue">Option</span> <span style="color:blue">Explicit</span>
    
    <span style="color:blue">Private</span> Type POINTAPI
            X <span style="color:blue">As</span> <span style="color:blue">Long</span>
            Y <span style="color:blue">As</span> <span style="color:blue">Long</span>
    <span style="color:blue">End</span> Type
    
    <span style="color:blue">Private</span> Type MOUSEHOOKSTRUCT
            pt <span style="color:blue">As</span> POINTAPI
            hwnd <span style="color:blue">As</span> <span style="color:blue">Long</span>
            wHitTestCode <span style="color:blue">As</span> <span style="color:blue">Long</span>
            dwExtraInfo <span style="color:blue">As</span> <span style="color:blue">Long</span>
    <span style="color:blue">End</span> Type
    
    <span style="color:blue">Private</span> <span style="color:blue">Declare</span> <span style="color:blue">Function</span> FindWindow <span style="color:blue">Lib</span> <span style="color:#a31515">"user32"</span> _
                                            <span style="color:blue">Alias</span> <span style="color:#a31515">"FindWindowA"</span> ( _
                                                            <span style="color:blue">ByVal</span> lpClassName <span style="color:blue">As</span> <span style="color:blue">String</span>, _
                                                            <span style="color:blue">ByVal</span> lpWindowName <span style="color:blue">As</span> <span style="color:blue">String</span>) <span style="color:blue">As</span> <span style="color:blue">Long</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Declare</span> <span style="color:blue">Function</span> GetWindowLong <span style="color:blue">Lib</span> <span style="color:#a31515">"user32.dll"</span> _
                                            <span style="color:blue">Alias</span> <span style="color:#a31515">"GetWindowLongA"</span> ( _
                                                            <span style="color:blue">ByVal</span> hwnd <span style="color:blue">As</span> <span style="color:blue">Long</span>, _
                                                            <span style="color:blue">ByVal</span> nIndex <span style="color:blue">As</span> <span style="color:blue">Long</span>) <span style="color:blue">As</span> <span style="color:blue">Long</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Declare</span> <span style="color:blue">Function</span> SetWindowsHookEx <span style="color:blue">Lib</span> <span style="color:#a31515">"user32"</span> _
                                            <span style="color:blue">Alias</span> <span style="color:#a31515">"SetWindowsHookExA"</span> ( _
                                                            <span style="color:blue">ByVal</span> idHook <span style="color:blue">As</span> <span style="color:blue">Long</span>, _
                                                            <span style="color:blue">ByVal</span> lpfn <span style="color:blue">As</span> <span style="color:blue">Long</span>, _
                                                            <span style="color:blue">ByVal</span> hmod <span style="color:blue">As</span> <span style="color:blue">Long</span>, _
                                                            <span style="color:blue">ByVal</span> dwThreadId <span style="color:blue">As</span> <span style="color:blue">Long</span>) <span style="color:blue">As</span> <span style="color:blue">Long</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Declare</span> <span style="color:blue">Function</span> CallNextHookEx <span style="color:blue">Lib</span> <span style="color:#a31515">"user32"</span> ( _
                                                            <span style="color:blue">ByVal</span> hHook <span style="color:blue">As</span> <span style="color:blue">Long</span>, _
                                                            <span style="color:blue">ByVal</span> nCode <span style="color:blue">As</span> <span style="color:blue">Long</span>, _
                                                            <span style="color:blue">ByVal</span> wParam <span style="color:blue">As</span> <span style="color:blue">Long</span>, _
                                                            lParam <span style="color:blue">As</span> <span style="color:blue">Any</span>) <span style="color:blue">As</span> <span style="color:blue">Long</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Declare</span> <span style="color:blue">Function</span> UnhookWindowsHookEx <span style="color:blue">Lib</span> <span style="color:#a31515">"user32"</span> ( _
                                                            <span style="color:blue">ByVal</span> hHook <span style="color:blue">As</span> <span style="color:blue">Long</span>) <span style="color:blue">As</span> <span style="color:blue">Long</span>
    
    <span style="color:green">'Private Declare Function PostMessage Lib "user32.dll" _</span>
    <span style="color:green">'                                         Alias "PostMessageA" ( _</span>
    <span style="color:green">'                                                         ByVal hwnd As Long, _</span>
    <span style="color:green">'                                                         ByVal wMsg As Long, _</span>
    <span style="color:green">'                                                         ByVal wParam As Long, _</span>
    <span style="color:green">'                                                         ByVal lParam As Long) As Long</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Declare</span> <span style="color:blue">Function</span> WindowFromPoint <span style="color:blue">Lib</span> <span style="color:#a31515">"user32"</span> ( _
                                                            <span style="color:blue">ByVal</span> xPoint <span style="color:blue">As</span> <span style="color:blue">Long</span>, _
                                                            <span style="color:blue">ByVal</span> yPoint <span style="color:blue">As</span> <span style="color:blue">Long</span>) <span style="color:blue">As</span> <span style="color:blue">Long</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Declare</span> <span style="color:blue">Function</span> GetCursorPos <span style="color:blue">Lib</span> <span style="color:#a31515">"user32.dll"</span> ( _
                                                            <span style="color:blue">ByRef</span> lpPoint <span style="color:blue">As</span> POINTAPI) <span style="color:blue">As</span> <span style="color:blue">Long</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Const</span> WH_MOUSE_LL <span style="color:blue">As</span> <span style="color:blue">Long</span> = 14
    <span style="color:blue">Private</span> <span style="color:blue">Const</span> WM_MOUSEWHEEL <span style="color:blue">As</span> <span style="color:blue">Long</span> = &H20A
    <span style="color:blue">Private</span> <span style="color:blue">Const</span> HC_ACTION <span style="color:blue">As</span> <span style="color:blue">Long</span> = 0
    <span style="color:blue">Private</span> <span style="color:blue">Const</span> GWL_HINSTANCE <span style="color:blue">As</span> <span style="color:blue">Long</span> = (-6)
    
    <span style="color:green">'Private Const WM_KEYDOWN As Long = &H100</span>
    <span style="color:green">'Private Const WM_KEYUP As Long = &H101</span>
    <span style="color:green">'Private Const VK_UP As Long = &H26</span>
    <span style="color:green">'Private Const VK_DOWN As Long = &H28</span>
    <span style="color:green">'Private Const WM_LBUTTONDOWN As Long = &H201</span>
    
    <span style="color:blue">Private</span> mLngMouseHook <span style="color:blue">As</span> <span style="color:blue">Long</span>
    <span style="color:blue">Private</span> mListBoxHwnd <span style="color:blue">As</span> <span style="color:blue">Long</span>
    <span style="color:blue">Private</span> mbHook <span style="color:blue">As</span> <span style="color:blue">Boolean</span>
    <span style="color:blue">Private</span> mCtl <span style="color:blue">As</span> MSForms.Control
    <span style="color:blue">Dim</span> n <span style="color:blue">As</span> <span style="color:blue">Long</span>
    
    <span style="color:blue">Sub</span> HookListBoxScroll(frm <span style="color:blue">As</span> <span style="color:blue">Object</span>, ctl <span style="color:blue">As</span> MSForms.Control)
    <span style="color:blue">Dim</span> lngAppInst <span style="color:blue">As</span> <span style="color:blue">Long</span>
    <span style="color:blue">Dim</span> hwndUnderCursor <span style="color:blue">As</span> <span style="color:blue">Long</span>
    <span style="color:blue">Dim</span> tPT <span style="color:blue">As</span> POINTAPI
         GetCursorPos tPT
         hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
         <span style="color:blue">If</span> <span style="color:blue">Not</span> frm.ActiveControl <span style="color:blue">Is</span> ctl <span style="color:blue">Then</span>
                 ctl.SetFocus
         <span style="color:blue">End</span> <span style="color:blue">If</span>
         <span style="color:blue">If</span> mListBoxHwnd <> hwndUnderCursor <span style="color:blue">Then</span>
                 UnhookListBoxScroll
                 <span style="color:blue">Set</span> mCtl = ctl
                 mListBoxHwnd = hwndUnderCursor
                 lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
                 <span style="color:green">' PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&</span>
                 <span style="color:blue">If</span> <span style="color:blue">Not</span> mbHook <span style="color:blue">Then</span>
                         mLngMouseHook = SetWindowsHookEx( _
                                                         WH_MOUSE_LL, <span style="color:blue">AddressOf</span> MouseProc, lngAppInst, 0)
                         mbHook = mLngMouseHook <> 0
                 <span style="color:blue">End</span> <span style="color:blue">If</span>
         <span style="color:blue">End</span> <span style="color:blue">If</span>
    <span style="color:blue">End</span> <span style="color:blue">Sub</span>
    
    <span style="color:blue">Sub</span> UnhookListBoxScroll()
         <span style="color:blue">If</span> mbHook <span style="color:blue">Then</span>
                    <span style="color:blue">Set</span> mCtl = <span style="color:blue">Nothing</span>
                 UnhookWindowsHookEx mLngMouseHook
                 mLngMouseHook = 0
                 mListBoxHwnd = 0
                 mbHook = <span style="color:blue">False</span>
            <span style="color:blue">End</span> <span style="color:blue">If</span>
    <span style="color:blue">End</span> <span style="color:blue">Sub</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Function</span> MouseProc( _
                 <span style="color:blue">ByVal</span> nCode <span style="color:blue">As</span> <span style="color:blue">Long</span>, <span style="color:blue">ByVal</span> wParam <span style="color:blue">As</span> <span style="color:blue">Long</span>, _
                 <span style="color:blue">ByRef</span> lParam <span style="color:blue">As</span> MOUSEHOOKSTRUCT) <span style="color:blue">As</span> <span style="color:blue">Long</span>
    <span style="color:blue">Dim</span> idx <span style="color:blue">As</span> <span style="color:blue">Long</span>
            <span style="color:blue">On</span> <span style="color:blue">Error</span> <span style="color:blue">GoTo</span> errH
         <span style="color:blue">If</span> (nCode = HC_ACTION) <span style="color:blue">Then</span>
                 <span style="color:blue">If</span> WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd <span style="color:blue">Then</span>
                         <span style="color:blue">If</span> wParam = WM_MOUSEWHEEL <span style="color:blue">Then</span>
                                    MouseProc = <span style="color:blue">True</span>
    <span style="color:green">'                                If lParam.hwnd > 0 Then</span>
    <span style="color:green">'                                        PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0</span>
    <span style="color:green">'                                Else</span>
    <span style="color:green">'                                        PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0</span>
    <span style="color:green">'                                End If</span>
    <span style="color:green">'                                PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0</span>
                                    <span style="color:blue">If</span> lParam.hwnd > 0 <span style="color:blue">Then</span> idx = -1 <span style="color:blue">Else</span> idx = 1
                                 idx = idx + mCtl.ListIndex
                                 <span style="color:blue">If</span> idx >= 0 <span style="color:blue">Then</span> mCtl.ListIndex = idx
                                    <span style="color:blue">Exit</span> <span style="color:blue">Function</span>
                         <span style="color:blue">End</span> <span style="color:blue">If</span>
                 <span style="color:blue">Else</span>
                         UnhookListBoxScroll
                 <span style="color:blue">End</span> <span style="color:blue">If</span>
         <span style="color:blue">End</span> <span style="color:blue">If</span>
         MouseProc = CallNextHookEx( _
                                 mLngMouseHook, nCode, wParam, <span style="color:blue">ByVal</span> lParam)
         <span style="color:blue">Exit</span> <span style="color:blue">Function</span>
    errH:
         UnhookListBoxScroll
    <span style="color:blue">End</span> <span style="color:blue">Function</span>
    <span style="color:green">'''''''' end normal module code</span>
    
    <span style="color:green">'http://social.Msdn.microsoft.com/Forums/en-US/isvvba/thread/7d584120-a929-4e7c-9ec2-9998ac639bea#7738fb96-12be-4e3c-af5c-abaae64a5e94</span>
    <span style="color:green">'</span>
    <span style="color:green">'19-Jul-2012</span>
    
    <span style="color:green">''''' Userform code</span>
    <span style="color:blue">Private</span> <span style="color:blue">Sub</span> comboBox1_MouseMove( _
                            <span style="color:blue">ByVal</span> Button <span style="color:blue">As</span> <span style="color:blue">Integer</span>, <span style="color:blue">ByVal</span> Shift <span style="color:blue">As</span> <span style="color:blue">Integer</span>, _
                            <span style="color:blue">ByVal</span> X <span style="color:blue">As</span> <span style="color:blue">Single</span>, <span style="color:blue">ByVal</span> Y <span style="color:blue">As</span> <span style="color:blue">Single</span>)
                    HookListBoxScroll <span style="color:blue">Me</span>, <span style="color:blue">Me</span>.ComboBox1
    <span style="color:blue">End</span> <span style="color:blue">Sub</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Sub</span> ListBox1_MouseMove( _
                            <span style="color:blue">ByVal</span> Button <span style="color:blue">As</span> <span style="color:blue">Integer</span>, <span style="color:blue">ByVal</span> Shift <span style="color:blue">As</span> <span style="color:blue">Integer</span>, _
                            <span style="color:blue">ByVal</span> X <span style="color:blue">As</span> <span style="color:blue">Single</span>, <span style="color:blue">ByVal</span> Y <span style="color:blue">As</span> <span style="color:blue">Single</span>)
             HookListBoxScroll <span style="color:blue">Me</span>, <span style="color:blue">Me</span>.ListBox1
    <span style="color:blue">End</span> <span style="color:blue">Sub</span>
    
    <span style="color:blue">Private</span> <span style="color:blue">Sub</span> ListBox2_MouseMove( _
                            <span style="color:blue">ByVal</span> Button <span style="color:blue">As</span> <span style="color:blue">Integer</span>, <span style="color:blue">ByVal</span> Shift <span style="color:blue">As</span> <span style="color:blue">Integer</span>, _
                            <span style="color:blue">ByVal</span> X <span style="color:blue">As</span> <span style="color:blue">Single</span>, <span style="color:blue">ByVal</span> Y <span style="color:blue">As</span> <span style="color:blue">Single</span>)
             HookListBoxScroll <span style="color:blue">Me</span>, <span style="color:blue">Me</span>.ListBox2
    <span style="color:blue">End</span> <span style="color:blue">Sub</span>
    <span style="color:blue">Private</span> <span style="color:blue">Sub</span> UserForm_Initialize()
    <span style="color:blue">Dim</span> i <span style="color:blue">As</span> <span style="color:blue">Long</span>
    <span style="color:blue">Dim</span> s <span style="color:blue">As</span> <span style="color:blue">String</span>
            s = <span style="color:#a31515">"this is line "</span>
            <span style="color:blue">For</span> i = 1 <span style="color:blue">To</span> 50
                            <span style="color:blue">Me</span>.ComboBox1.AddItem s & i
                            <span style="color:blue">Me</span>.ListBox1.AddItem s & i
                            <span style="color:blue">Me</span>.ListBox2.AddItem s & i
            <span style="color:blue">Next</span>
    <span style="color:blue">End</span> <span style="color:blue">Sub</span>
    <span style="color:blue">Private</span> <span style="color:blue">Sub</span> UserForm_QueryClose(Cancel <span style="color:blue">As</span> <span style="color:blue">Integer</span>, CloseMode <span style="color:blue">As</span> <span style="color:blue">Integer</span>)
            UnhookListBoxScroll
    <span style="color:blue">End</span> <span style="color:blue">Sub</span>
    <span style="color:green">''''''' end Userform code</span>
    
    

    You can delete the commented PostMessage code

    Peter Thornton

    Hi Peter,

    Can this code be adapted for to page scroll in a multipage object?

    regards,

    Mike


    Monday, August 20, 2012 8:18 AM
  • > Can this code be adapted for to page scroll in a multipage object?

    In very light testing it seems easily adaptable for a multipage. Referring to the previous example (ie the code you quoted), in the normal module code, in Function MouseProc()...

    change
         idx = idx + mCtl.ListIndex
         If idx >= 0 Then mCtl.ListIndex = idx
    to
         idx = idx + mCtl.Value
         If idx >= 0 And idx < mCtl.Pages.Count Then
                 mCtl.Value = idx
         End If

    In the userform add a similar mousemove for the multipage

    Private Sub MultiPage1_MouseMove(ByVal Index As Long, _
                 ByVal Button As Integer, ByVal Shift As Integer, _
                 ByVal X As Single, ByVal Y As Single)
            HookListBoxScroll Me, Me.MultiPage1
    End Sub

    Obviously change the name MultiPage1 to suit

    The multipage mousemove event will not fire if the mouse is over certain window'ed type controls, eg Listbox & Combo.

    If the code is to cater for both a multipage and  List/combo, a global flag could be set in HookListBoxScroll to indicate the control type, and in turn under an IF whether to process a multipage or List/Combo.

    As I said, I've barely tested. Fully test your scenario, scrolling while the mouse is over each control on each page for any unexpected catches.

    One thing I'd look at in more detail the check - If Not frm.ActiveControl Is ctl, etc - this was necessary in the original example, not sure if useful or possibly counter productive with the multipage.

    Peter Thornton

    Monday, August 20, 2012 10:27 AM
    Moderator
  • Hi Peter,

    Many thanks for the prompt reply,

    I have applied sugested changes, however, this rotates through the pages, I whish to be able to apply mouse scrollability to a verticle scroll bar on a page in a multipage object,

    Just answered my own question, in Function MouseProc()...; changed the following to increments of 10 for faster scroll speed;

    If lParam.hwnd > 0 Then idx = -10 Else idx = 10

    And changed your suggestion to;

    idx = idx + mCtl.Item(mCtl.Value).ScrollTop

    If idx >= 0 And idx < ((mCtl.Item(mCtl.Value).ScrollHeight - mCtl.Height) + 17.25) Then

    mCtl.Item(mCtl.Value).ScrollTop = idx

    End If

    Works a charm,

    Many thanks for the help,

    Regards,

    Mike


    • Proposed as answer by Triple_M Tuesday, August 21, 2012 8:55 AM
    • Unproposed as answer by Triple_M Tuesday, August 21, 2012 8:55 AM
    • Edited by Triple_M Tuesday, August 21, 2012 9:20 AM
    Tuesday, August 21, 2012 6:31 AM
  • Ah, I misread precisely what you were asking for but it looks like you've got the idea how to adapt the approach!

    If you only want to enable mouse scroll on one or some of the multipages, in the multipage mousemove event include something like this, say for pages 0, 2, 3 and 6 only

    Dim bFlag As Boolean
         Select Case MultiPage1.Value
         Case 0, 2, 3, 6
                 bFlag = True
         End Select
            If bFlag Then
                 HookListBoxScroll Me, Me.MultiPage1
         End If

    Peter Thornton

    Tuesday, August 21, 2012 9:47 AM
    Moderator
  • Hi Peter -

    Thanks a million for your solution.  I'm a so-so VBA programmer - and would never have been able to implement this on my own.  Your code proposed below works brilliantly on Excel 32bit, but as expected (and predicted by you) it doesn't fare as well on 64 bit.  I have no experiences with API calls - outside of copying and pasting someone else's code :)

    Any thoughts on getting this code to fail over to 64bit API's so I might have a universal cross-platform solution?

    Thanks again...

    Christopher Gebo

    Thursday, September 27, 2012 4:34 PM
  • Christopher, glad you got it working. It took a while with a fair bit of trial and error!

    I don't have Office-64 so I haven't looked into converting code, apart than getting an overview. But why not have a go yourself. Start with Jan Karel Pieterse's page
    http://www.jkp-ads.com/articles/apideclarations.asp

    I'm reasonably confident this mouse scroll code can be converted because there appear to be "PtrSafe" equivalents of all the APIs used, see the file Win32API_PtrSafe.TXT in this download
    http://www.microsoft.com/downloads/en/confirmation.aspx?FamilyID=035b72a5-eef9-4baf-8dbc-63fbd2dd982b&displaylang=en

    You could either make separate versions for Office 32/64 bit, or I assume it should be possible to make one version with liberal use of the conditional constant #If Win64 etc

    See how you get on and do post back with your progress, even if stumbling. Sooner or later I will have to adapt all my code so maybe you can save me some time with this lot :-)

    Peter Thornton

    <gebo1> wrote in message news:47076a88-058d-4fbe-8d62-411d6c7dc9e1@communitybridge.codeplex.com...

    Hi Peter -

    Thanks a million for your solution. I'm a so-so VBA programmer - and would never have been able to implement this on my own. Your code proposed below works brilliantly on Excel 32bit, but as expected (and predicted by you) it doesn't fare as well on 64 bit. I have no experiences with API calls - outside of copying and pasting someone else's code :)

    Any thoughts on getting this code to fail over to 64bit API's so I might have a universal cross-platform solution?

    Thanks again...

    Christopher Gebo

    Saturday, September 29, 2012 10:48 AM
    Moderator
  • Will do - thanks for the pointers in the right (?) direction :)

    Cheers!

    Tuesday, October 2, 2012 12:52 AM
  • I know this post is not new, but certainly useful. If it would be possible to expand on it for a listbox on a worksheet, it sure would be appreciated. I have tried several things and the problem seems to be the handle for the worksheet. thanks, roger

    EDIT: Could that be a multiline textbox instead of a listbox. I just noticed the code above is strictly designed for a listbox.

    • Edited by rdwray_666 Thursday, September 19, 2013 11:55 AM
    Thursday, September 19, 2013 11:44 AM
  • Hi Peter

    I found this quite useful, but I am having some difficulties applying it to my code. Reason being that I am not using a ComboBox or Listbox in a UserForm. Instead, I am inserting a ActiveX ControlBox. I am quite new to VB, not sure what are the main difference. Learning while writing as I go along. Appreciate if you can shed some light on how do I go about changing the code to accommodate this ComboBox.

    Thanks,

    Hugo

    Monday, January 20, 2014 6:09 AM
  • I'm not here very often these days and only just seen your message, hope you've solved your problem if not post back.

    Peter Thornton

    Tuesday, March 18, 2014 11:23 AM
    Moderator
  • Hi, sorry to dredge this up once again, however I'm trying to get this to work on a Frame within a userform and can't find anything about scrolling frames anywhere.

    Basically I need some controls to remain static on the form, whilst others contained within the frame scroll using the mouse wheel.  Is there anyway your code solutions above can be adapted to frames?

    Thankyou!

    Friday, May 2, 2014 1:49 PM
  • Yes Chris it works fine with a Frame to scroll embedded controls in/out of view, in fact that's what I mainly use it for. Just adapt everything in the example(s) that refers to a listbox to your Frame, including the mouse move event.
    Friday, May 2, 2014 2:58 PM
    Moderator
  • Hello Peter, to scroll userform you posted the below code in another topic, but I could not figure it out, can you post a complete code

    'In the declarations area
    Private mObj As Object 
    
    'change
    Sub HookListBoxScroll(frm As Object, , ctl As MSForms.Control)
    'to
    Sub HookListBoxScroll(frm As Object, obj As Object)
    
    'add new If
        If Not frm Is obj Then  ' new
            If Not frm.ActiveControl Is obj Then ' existing
                obj.SetFocus
            End If
        End If
    
    ' in MouseProc()
    If lParam.hwnd > 0 Then idx = -1 Else idx = 1 ' existing code
    
    ' new
    If TypeName(mObj) = "UserForm1" Or TypeName(mObj) = "Frame" Then
        If mObj.ScrollTop + idx * 9 <= 0 Then
            mObj.ScrollTop = 0
        Else
            mObj.ScrollTop = mObj.ScrollTop + idx * 9
        End If
    ElseIf TypeName(mObj) = "ListBox" Then
        idx = idx + mObj.ListIndex
        If idx >= 0 Then mObj.ListIndex = idx
        ' similar for a ComboBox
    ElseIf TypeName(mObj) = "MultiPage" Then
        ' this selects adjecent pages, but to scroll a page's
        ' scrollbar similar to a Frame or Form
        idx = idx + mObj.Value
        If idx >= 0 And idx < mObj.Pages.Count Then
            mObj.Value = idx
        End If
    End If
    
    Exit Function  ' existing code
    
    ' in UnhookListBoxScroll
    Set mObj = Nothing
    
    ' In the form
    Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        HookListBoxScroll Me, Me
    End Sub
    
    ' and similar in the mousemove events of other controls
    
    ' be sure to include this (you didn't in the file you uploaded)
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        UnhookListBoxScroll
    End Sub

    I've made the code generic and as short as possible but better to adapt to the controls you have, replace mCtl as MSForms.Controls, include simple flags to direct which control or form should be handled in the MouseProc routine.

    Sunday, July 20, 2014 2:13 PM
  • Hello again,

    I think it should be possible to adapt the above into the original if you follow the instructions. If you get errors do Debug / Compile to flag anything which will not compile (ensure each module is headed 'Option Explicit').

    This is already an extremely long thread so probably better not to re-post the entire code again for what is only a few small changes to the original code to adapt for to different controls. See how you get on, if still stuck I'll see if I can email it to you.

    • Proposed as answer by jdubei Thursday, August 28, 2014 9:21 PM
    • Unproposed as answer by jdubei Thursday, August 28, 2014 9:21 PM
    Tuesday, July 22, 2014 3:13 PM
    Moderator
  • I am not very experienced with API calls, however, I was able to convert it for 64 bit and 32 bit with the help of the resources cited above. I tested the code in 3 different environments: Excel 2010 Version 14.0.7 (32bit) installed on Win 8 (64bit); Excel 2013 Version 15.0.4 (64 bit) installed on Win 7 (64 bit); and Excel 2013 Version 15.0.4 (64 bit) installed on Win 8 (64 bit). The code appears to be working on all 3 environments but it crashes after 1 min of scroll in last 2 environments (Excel 2013/64 bit). I am not sure if the problem is in the code below or anywhere else as I was testing it with a file that has a large amount of code. I will be doing more testing, however, if anyone has any suggestions at this point or has other versions/alternatives for using mouse scroll within a form, I would be very appreciative. I am not getting any error. Excel simply crashes with "Microsoft Excel has stopped working". Thanks, Joe.

    '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 MSForms.control
    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 MSForms.control)
        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 Not frm.ActiveControl Is ctl Then
               ctl.SetFocus
        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 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 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 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

    • Proposed as answer by jdubei Thursday, August 28, 2014 9:53 PM
    Thursday, August 28, 2014 9:27 PM
  • I have tested the code again using a simple form with a frame. It appears that the crashes I was encountering were caused by other reasons (possibly by using too many controls in the frame - 200 to 300). The code appears to be working fine on all three environments mentioned above. Joe.
    Thursday, August 28, 2014 10:00 PM
  • Hello jdubei, I tested the code with a simple form to scroll the userform, but I get type mismatch error, you can see the uploaded file here

    Thank you

    Friday, August 29, 2014 5:04 AM
  • there are two variables defined as MSForms.Control -- mctl and ctl (inside HookListBoxScroll sub). These have to be changed to object along with other small changes in order to have the code work with userform. see below.

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

    • Proposed as answer by Ahmed Morsyy Friday, August 29, 2014 3:28 PM
    Friday, August 29, 2014 3:02 PM
  • Thank you jdubei, that works perfect. I'm using Excel 2010 (32 bit) on windows 7 (64 bit).

    Can you change the speed of scrolling?

    Friday, August 29, 2014 3:27 PM
  • how to use mouse wheel in excel 2010
    • Proposed as answer by pvieira28 Sunday, September 28, 2014 11:06 AM
    Sunday, September 28, 2014 11:06 AM
  • I've only just seen recent posts in this thread

    Under the conditional #VBA7 there's no need to copy an entire function twice purely for respective arguments and return declarations, simply lke this

    #If VBA7 Then
    Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As Long
    #Else
    Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long
    #End If
    
    ' code
    
    End Sub

    Monday, September 29, 2014 12:07 PM
    Moderator
  • Can you change the speed of scrolling?

    Instead of changing the position in units of one, increase (or decrease for up) the units by a suitable factor. You could hard code the "speed" factor or make it user configurable.
    Monday, September 29, 2014 12:17 PM
    Moderator
  • Yep, still here! I heard there was a video about this but I haven't seen it.

    Not sure what your compile error is but it should work fine in Word or any VBA app. I assume you're not using 64bit Office, but if you are the APIs needs adapting for LongPtr and in one case for a LongLong.

    Probably something simple but if stuck upload your (non sensitive) file to a file sharing site, eg www.onedrive.com and I'll have a look.

    Wednesday, November 5, 2014 11:24 AM
    Moderator
  • Found the answer. It was in one of your later posts. It dealt with the long vs. longptr setting when programming in Word2013/64 bit.

    Thanks.

    Roy

    Wednesday, November 5, 2014 11:44 AM
  • Hi Peter,

    I don't know if the thread is still alive but here goes nothing..

    I used your code, and everything is working perfercly ! But I would like to make a small change and apparently I'm not able to do it by myself...

    I would like to enable the scroll feature but not in a Userform, directly in the worksheet.

    Can you help me with this ?

    Thanks for your time and for this great piece of work :D


    Tuesday, July 7, 2015 2:45 PM
  • Samuel, well it it looks like you made the thread alive again :)

    I haven't looked at adapting this to scroll a sheet but I'm sure it could do, bit of API work involved though. But the obvious question, as worksheets already scroll by default - why?

    Wednesday, July 8, 2015 2:35 PM
    Moderator
  • Hi I know this post was from a year ago, but on the off chance you are still active.

    I have managed to get everything working with both the userform and the listbox being able to scroll. However when I scroll with the userform as well as the listbox, I am unable to unhook the mouse scroll and therefore no other programs can scroll until excel is closed at which point it freezes and restarts excel.

    If anyone knows how to fix this I would be most appreciative.

    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        UnhookListBoxScroll
        UnhookFormScroll
    End Sub

    This is what I am using currently


    • Edited by Kauket25 Sunday, December 13, 2015 7:54 AM
    Saturday, December 12, 2015 10:05 PM
  • Yep, still here!

    You've obviously adapted things so without seeing your code hard to suggest where things are going wrong. However it looks like you've got two hook routines, that might be alright providing only one can ever be running at any one time. Always cancel one before starting the other.

    Probably better only to have one hook and adapt so it stops and starts to scroll whatever control or form is known to be under the mouse. That would mean changing objCt As Control to As Object.

    Sunday, December 13, 2015 11:14 AM
    Moderator
  • Hey thanks for getting back to me.

    I managed to figure it out by using a reference cell as to whether or not the MouseProc macro ran, that's where I seemed to have my issue. Not very elegant but it works.

    However I then came up against a few more issues. When I had another workbook open it would say subscript out of range. So i then had to establish that it would only run when the workbook it originated in was the active workbook.

    So far I is working but I will just have to wait and see. I also didn't have to change for 64 bit for userform scroll unlike when I needed it for the listbox. 

    Thankyou so much for taking the time to write this code in the first place, it was genius and a god send.

    Private Function MouseProc( _
        ByVal nCode As Long, ByVal wParam As Long, _
        ByRef lParam As MOUSEHOOKSTRUCT) As Long
    
    If ActiveWorkbook.Name Like "*Repair Log*" Then
    
        If Worksheets("REF DATA").Range("N2") = "Stop" Then
            UnhookFormscroll
            Exit Function
        Else
        
        On Error GoTo errH 'Resume Next
        If (nCode = HC_ACTION) Then
            Debug.Print "action"
            Debug.Print "right window"
            If wParam = WM_MOUSEWHEEL Then
                Debug.Print "mouse scroll"
                MouseProc = True
                If lParam.hwnd > 0 Then
                    mForm.ScrollTop = Application.Max(0, mForm.ScrollTop - cSCROLLCHANGE)
                Else
                    mForm.ScrollTop = Application.Min(mForm.ScrollHeight - mForm.InsideHeight, mForm.ScrollTop + cSCROLLCHANGE)
                End If
                Exit Function
            End If
        End If
    End If
        MouseProc = CallNextHookEx( _
        mLngMouseHook, nCode, wParam, ByVal lParam)
        Exit Function
    errH:
        UnhookFormscroll
    
    Else
        Exit Function
    
    End If
    
    End Function
    Monday, December 14, 2015 5:21 AM
  • Thanks for your comments!

    About your workaround I don't quite follow what's going on but in theory it shouldn't be needed, or at least not quite like that.  But as the saying goes if it works it works I suppose!

    In passing I wouldn't use those app.Min & Max functions, just simple If..Else..If

    Monday, December 14, 2015 1:08 PM
    Moderator
  • No worries they are well deserved. 

    About my workaround, it is odd because I am basically learning this stuff on the go and for some reason I can't get the macro to unhook correctly. So when I try and then scroll in a different program or even in excel I can't scroll with the mouse. 

    Also on a side note can this sort of code start to cause instability in windows? Ever since I started using the codes for mouse scroll, funny things have been happening. Excel seems to crash a lot too. It is almost as if when the userform is closed and the unhook is supposed to happen it doesn't leaving the API's still running or something.

    Did you mean take out the min & max completely? I'm not sure, I am beginner and a terrible one at that. But thanks for getting back to me.

    Tuesday, December 15, 2015 10:53 AM
  • Indeed any error within the hook might crash Excel instantly without warning, normal error handling probably won't help. Crashes can also occur while debugging and stepping through the code, that's different but be prepared for it with backups while developing.

    To mitigate any slowdown do the minimum necessary to scroll your window and ideally nothing else, with 100% error free code! Also ensure the hook is cancelled when not needed, ie the mouse is not over the given window, but see next.

    I'm not sure why your hook is not being cancelled. The first step detects if the mouse is over the anticipated window and if not call the Unhook. But best also call the Unhook any time you know you want it cancelled just to be sure, not least when the main form closes.

    About those Min/Max, merely that calling what are effectively external Excel worksheet functions is more work than simply If a>b scroll-up Elseif a<b scroll-down.


    Tuesday, December 15, 2015 1:01 PM
    Moderator
  • One more thing to add, I'm sure people have already figured this out.

    but in the MouseProc function the ListIndex needs to be checked to make sure the new index wont be greater then the max listindex. The way it is right now if the user scrolls (down) in a listbox and the listindex is already on the last line it will throw an error and then get unhooked in the error control, the user then cant scroll (up) as it has been unhooked.

    This can be handled a couple different ways and might not even be a problem depending on how you are hooking, but I like to limit errors as much as possible.

    its as simple of changing this in the MouseProc function

        If lParam.hWnd > 0 Then idx = -1 Else idx = 1
        idx = idx + mCtl.ListIndex
        If idx >= 0 Then mCtl.ListIndex = idx

    to this

        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

    obviously if your scroll speed jumps more then one index this will need changed a little.

    on another note this post is just amazing, never would have gotten it on my own.

    thanks everyone, the 64bit/32bit thing was huge.

    Monday, December 21, 2015 4:06 PM
  • Peter -

    I used your code to successfully scroll a listbox in a userform that requires first selecting the choice in the listbox and then clicking an Ok button. But I have another userform that navigates the workbook and I'm having trouble employing the mouse scroll code with that one. The difference is that the navigation userform, which displays a list of visible worksheets, activates on a listbox_click event, firing off the code that takes the user to the selected sheet. The scroll works fine with the list while the form is up, but after clicking and going to the selected sheet (the navigation userform is unloaded, of course) the mouse wheel will not scroll the active sheet until the cursor is taken over the vertical scrollbar or up into the ribbon. A quick fly up there and then the sheet will scroll. But escape or clicking on various cells does nothing until the cursor is moved off the worksheet.

    I thought it was a simple matter of putting the unhook call in the code that is fired when the listbox is clicked, but no go. I've tried a few other ploys, but no joy. Any ideas? Thanks.


    • Edited by Markh_Joy Tuesday, March 8, 2016 9:47 PM editing
    Tuesday, March 8, 2016 9:45 PM
  • Oops, just solved it: I was hiding the navigation userform, not unloading it. Unloading it did the trick. Obviously, because it was still "there" it retained the mouse hold. So to speak.
    Tuesday, March 8, 2016 10:25 PM
  • Hi Peter!

    I checked your code and it works for my Listboxes and Comboboxes. However, I could not make it work for Textboxes. Would you be able to extend your expertise and refine the code to make it also work for Textboxes which some of us are also using? Would greatly appreciate your help on this matter. Hope to hear from you soon.

    Monday, April 18, 2016 8:41 AM
  • The approach won't work for a textbox, at least not directly. What you could do is put textbox in a Frame. Adjust the Frame's size and scrollheight to suit, then size the textbox to the Frame's scrollheight and scrollwidth.

    Initiate scroll in the texbox's mousemove event but pass the Frame object. Then in the hook increment the object's Scrolltop up or down by a suitable amount, say +/- 12 points.

    Monday, April 18, 2016 2:41 PM
    Moderator
  • Hi Peter!

    The code proposed the 21st of August 2012 works perfectly for multipages, thanks! However I also have frames on some of the pages - how do I get the scroll to work on the multipage when the mouse is over a frame? Would really appreciate your help!

    Tuesday, April 19, 2016 8:15 AM
  • In the Frame's mousemove pass the either the Frame's Parent to the setup routine , if you want to scroll the Page itself, or the Frame's Parent.Parent if you want to scroll pages. Also of course in the Mutlipage's mousemove pass the same object as no doubt you already are.

    However if you want to scroll the Frame, pass the Frame object in the Frame's mousemove.

    Obviously, depending on what you are scrolling in the Hook itself adapt the code to change the scrollTop (of the Page or Frame), or the MultiPage Value to scroll to different pages. but don't attempt to scroll beyond the limits.

    Tuesday, April 19, 2016 8:56 PM
    Moderator
  • Hi

    I have a problem with that script on Excel 2007. When I want to scroll Frame and take mouse on frame, mouse is freeze but scroll is working and there is problem to take out mouse from frame. Where is the problem ??

    On one Excel 2007 is working on another don't (working on build nr .....43 .... SP....43 but on build nr .....47 .... SP .....43 it won't)

    Same problem is with a combobox - it won't show list in combobox only freeze a combobox

    Monday, April 25, 2016 4:18 PM
  • On one Excel 2007 is working on another don't (working on build nr .....43 .... SP....43 but on build nr .....47 .... SP .....43 it won't)

    Without access to your machine I can't give a suggestion, it sounds like there's something different with the mouse itself and/or driver in the different systems. I doubt the difference is related to the Excel build number.
    Wednesday, April 27, 2016 11:06 AM
    Moderator
  • I need help.

    Please i have very basic understanding of VBA. Can someone post the full code for a 64bit machine. So i can get the scroll working on my userform and combo box please. I know i resurrecting this thread but it is the only one i have seen with a good amount of response. Please help me!

    Friday, August 5, 2016 9:33 PM
  • I second that. So much info. Could someone please post the userform listbox combobox wheel scroll for 64 bit Windows 10 and 32 bit MS Office?
    • Edited by Sven622 Wednesday, August 10, 2016 2:59 AM
    Wednesday, August 10, 2016 2:57 AM
  • Master Peter,

    I'm trying to do something similar but can't seem to figure out the necessary modifications.  I have a bunch of combo boxes in a worksheet (not form or userform) that I would like to be able to use the mouse wheel to scroll through (the combo box options instead of the sheet itself).  Any ideas?  I'm using Windows 7 x64 and Office 10 x32.  Thanks.

    Monday, October 10, 2016 4:37 PM
  • From memory ActiveX comboboxes don't expose a window when on Worksheets as they do when on a form (unlike some other controls like ListBox which IIRC do). If so it won't be possible to adapt this scroll code.

    If you're working with stuff like this I'll assume you'll know enough about APIs to get your worksheet's window handle (classname: "EXCEL7", caption: Worksheet name), then get all it's child windows looking for a classname that includes "60000000" (actual name differs with versions). 

    Also try with a ListBox and a Frame on the sheet which should have similar classname windows

    Friday, October 14, 2016 2:30 PM
    Moderator
  • I came across this code while researching the same issue ... just want to thank everyone especially Peter to make this available. It was an interesting read! 
    Sunday, July 23, 2017 1:04 AM
  • Thank you very much Peter Thornton for your efforts and for publishing your code in July 2012.
    I discovered your code when I was looking for scrolling a list in a listbox in 2013. Wow!

    And also many thanks to all who contributed in the 32bit / 64bit discussion.

    This is amazing!!!  I still make grateful use of it.

    With regards,

    Saturday, October 7, 2017 10:44 AM
  • Hello Rü,

    Glad people are still finding it useful!

    Be careful with 64bit though, much more prone to problems if not implemented correctly, including anything else not obviously related that might error while the hook is running.

    Monday, October 9, 2017 3:13 PM
    Moderator
  • OMG ........A over five year software discussion. I am elated. Long live Excel\VBA....also I propose this mouse to be hereafter named "MIGHTYMOUSE THORNTON". For he surely saved my day :)
    Wednesday, October 18, 2017 1:54 AM
  • LOL!!

    Saturday, October 21, 2017 10:54 AM
    Moderator
  • Hi all,

    First thing thank you for those wonderful searches and explanations.

    I'm not a VBA expert but I think I managed to implement this code correctly inside my project.

    However I do receive the "Compile error: Argument not optional" on the following piece of listbox code when mouse point on it:

    Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
                 ByVal X As Single, ByVal Y As Single)
                 
    If Not Me.ActiveControl Is Me.ListBox1 Then
        Me.ListBox1.SetFocus
    End If
    
    HookListBoxScroll
    
    End Sub

    Here below the procedure which seems to make trouble:

    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
            
            If Not mbHook Then
                mLngMouseHook = SetWindowsHookEx( _
                                                WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
                mbHook = mLngMouseHook <> 0
            End If
        End If
    End Sub


    Has anyone faced the same issue and eventually came with a fix?

    Thanks in advance :D



    Monday, November 13, 2017 11:05 AM
  • Looking only at the code you posted you would indeed get a compile error trying to call HookListBoxScroll without incuding the two non optional arguments. Try this -

    Call HookListBoxScroll(Me, Me.ListBox1)


    Monday, November 13, 2017 1:11 PM
    Moderator
  • Hi Peter, thanks for the quick reply.

    I'm not familiar yet with all the argument thing so I was not able to see this myself... It seems to be fine.

    Now I get the following error:

    "run time error 453: can't find dll entry point in user32.dll" for the first one and in "User32" for the second one

    on the two following functions:

    lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
    
    &
    
    mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)

    As I'm not administrator on this machine I guess I can't fix this DLL issue.

    In this case I will wait to be home to try to figure out what is wrong with my User32.DLL

    Am I correct? or is it due to the code itself?

    Have a good day!

    FYI, here below the full code inserted in a normal module (basically a copy paste from what I've found in this discussion):

    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
        #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
        #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
    #Else
        Private Declare Function FindWindow Lib "user32" ()
        Private Declare Function GetWindowLong Lib "user32.dll" ()
        Private Declare Function SetWindowsHookEx Lib "user32" ()
        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 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)
    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
            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 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 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 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 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 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

    Tuesday, November 14, 2017 7:33 AM
  • Either you didn't copy/paste correctly or the source is incorrect but the following declarations in the following APIs declared in the not VBA7 section are incomplete, no arguments

    #IF VBA7

    #Else
    FindWindow, GetWindowLong and SetWindowsHookEx
    #End If

    Examples of what you copied is included several times in this thread in which you can find the correct declarations.

    I don't want to discourage you but what's being implemented here is a kind of low level hook which, if not understood and adapted correctly for the overall scenario, can easily lead to complete crashes with no warning. x64 is particularly sensitive and, even though the declarations look correct in theory, will likely need additional work to work reliably.

    Tuesday, November 14, 2017 9:54 AM
    Moderator
  • Hi Peter,

    Once again you were right and I managed to get it working.

    Somehow part of my code was commented (the alias for Findwindow, Getwindowlong and Setwindowshookex).

    Have a very good day and thanks again :D

    Tuesday, November 14, 2017 2:45 PM
  • Hi Peter,

    I really hope I can resurrect this sub one more time and get your attention!  I have code I found online (can't remember exactly where) that I believe is an offshoot of your original code found in this thread.  The code works great for my ComboBoxes, but I can't get it to UnHook the mouse and return to regular behavior once the Userform is terminated.  Could you please look at the below code and help figure out how to get the UnHook portion of the code to work?

    Regular Module Code:

    Option Explicit
    
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    
    Declare Function GetForegroundWindow Lib "user32" () As Long
    
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
    
    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
    
    Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
    ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    
    Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    
    Type POINTAPI
      X As Long
      Y As Long
    End Type
    
    Type MSLLHOOKSTRUCT 'Will Hold the lParam struct Data
        pt As POINTAPI
        mouseData As Long ' Holds Forward\Bacward flag
        flags As Long
        time As Long
        dwExtraInfo As Long
    End Type
    
    Const HC_ACTION = 0
    Const WH_MOUSE_LL = 14
    Const WM_MOUSEWHEEL = &H20A
    
    Dim hhkLowLevelMouse, lngInitialColor As Long
    Dim udtlParamStuct As MSLLHOOKSTRUCT
    Public intTopIndex As Integer
    
    '==========================================================================
    '\\Copy the Data from lParam of the Hook Procedure argument to our Struct
    Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
    
       CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
        
       GetHookStruct = udtlParamStuct
        
    End Function
    
    '===========================================================================
    Function LowLevelMouseProc _
    (ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
       
        
        'Avoid XL crashing if RunTime error occurs due to Mouse fast movement
        On Error Resume Next
    
        If (nCode = HC_ACTION) Then
        
            If wParam = WM_MOUSEWHEEL Then
            
                    '\\ Don't process Default WM_MOUSEWHEEL Window message
                    LowLevelMouseProc = True
                
                    '\\ Change this to your userform name
                    With SkillChange_Begin.Controls(Worksheets("Skill Change Detail").Range("AV2").Value)
               
                  '\\ if rolling forward increase Top index by 1 to cause an Up Scroll
                    If GetHookStruct(lParam).mouseData > 0 Then
                    
                        .TopIndex = intTopIndex - 1
                    
                        '\\ Store new TopIndex value
                        intTopIndex = .TopIndex
                    
                    Else '\\ if rolling backward decrease Top index by 1 to cause _
                    '\\a Down Scroll
                    
                        .TopIndex = intTopIndex + 1
                        
                        '\\ Store new TopIndex value
                        intTopIndex = .TopIndex
                    
                    End If
                    
               End With
    
            End If
            
            Exit Function
        
        End If
    
        LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
    End Function
    
    '=======================================================================
    Sub Hook_Mouse()
    hhkLowLevelMouse = SetWindowsHookEx _
    (WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
    
    End Sub
    
    '========================================================================
    Sub UnHook_Mouse()
    
    If hhkLowLevelMouse <> 0 Then UnhookWindowsHookEx hhkLowLevelMouse
    
    End Sub
    
    

    Userform Code:

    Private Sub Skill1_1_DropButtonClick() Worksheets("Skill Change Detail").Range("AV2").Value = SkillChange_Begin _

    .Frame31.ActiveControl.Name intTopIndex = Skill1_1.TopIndex Hook_Mouse End Sub Private Sub UserForm_Terminate() UnHook_Mouse End Sub



    Tuesday, March 27, 2018 6:27 PM
  • Upon further research of the inner workings of these API calls, I discovered that the SetWindowsHookEx function sets a hook in place to monitor the mouse usage; this hook is deemed by a numeric value. In order to remove this hook, you must use the complimentary UnhookWindowsHookEx function and the numeric value assigned during the initial hook with the SetWindowsHookEx function.  There is no way of knowing this numeric value (that I could figure out) in order to release the hook, so I just devised the simple code below which does the trick:

    Sub UnHook_Mouse()
    
    Dim L1 As Long
    
    For L1 = 1 To 10000
        UnhookWindowsHookEx L1
    Next L1
    
    End Sub

    Friday, March 30, 2018 4:34 PM
  • Indeed the hook should be released with UnhookWindowsHookEx and as you say with a pointer to the handle of the hook. 

    But no need for that 1 to 10000 loop. You might release some other hook though typically the value is likely to be be much more than 10000. This pointer will have been returned by SetWindowsHookEx when the hook ws established, so simply store the pointer and use it to release 'your' hook.

    Note the following in the first example I posted near the top of this very long thread:

    Private mLngMouseHook As Long  ' stored at module level

    mLngMouseHook = SetWindowsHookEx ' create the hook and store its handle

    UnhookWindowsHookEx mLngMouseHook ' release the hook

    Friday, March 30, 2018 6:35 PM
    Moderator
  • Hey Peter,

    You are correct...using the for loop is in fact releasing a hook that is associated w/ another app and messing it up. I just can't figure out how to get the right pointer used in creating the mouse wheel hook. Isn't the code below doing what you suggested above, regarding storing the pointer and then using it in the UnhookWindowsHookEx function? Because it does not restore the default mouse wheel function.

    Sub Hook_Mouse()
    hhkLowLevelMouse = SetWindowsHookEx _
    (WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
    
    End Sub
    
    Sub UnHook_Mouse()
    
    UnhookWindowsHookEx hhkLowLevelMouse
    
    End Sub
    

    Tuesday, April 10, 2018 4:39 AM
  • I didn't look at the code you found somewhere else on line, apparently an offshoot of my original examples here. They've been widely reposted, as-is or adapted, sometimes with attribution but often without, sometimes even claiming copyright!

    But I've looked at it now. It does look like an 'offshoot' as it includes some specifics of what I posted here. But it seems to be standard mouse hook and little else, in particular without the functionality I included to handle the few MSForms controls that have windows, albeit not directly accessible.

    In simple terms it goes something like this -

    When the mouse is over the control, its mousemove event looks to start the hook, but if the hook is already running (if not mbHook)

    When starting the hook, get the control's window pointer handle assuming it's the window under the cursor at that moment, WindowFromPoint. There's more that should be done to be 100% sure got the right window (not included in my original example).

    In each callback check the cursor is still over the given control window, WindowFromPoint. If not terminate the hook, this aspect is important. The hook will start again same way if the mouse moves back over the control. In your code it looks like that's your "Frame31"

    Despite the mbHook flag I wonder if you are starting new hooks multiple times while an an existing hook is still running, maybe the flag and pointer are losing scope somehow. If so that would explain why your 1-10000 loop appeared to work, and why your 'UnhookWindowsHookEx hhkLowLevelMouse' apparantely fails, because other hooks are still running.

    To test, debug each new hook pointer in the Hook_Mouse and similarly in the UnHook_Mouse, there shold be matching consecutive pairs. Could do debug.? to the immediate window, or to cells, even to a log file.
    Thursday, April 12, 2018 10:43 AM
    Moderator
  • Sorry for making infinite this thread. I have used the Peter Thornton code modified by jdubei and Ahmed Morsyy for the mouse wheel to work in all environments but Excel closes when putting the cursor over the control without giving an error. It only closes. (Excel 2016 MSO (16.0.10827.20150) 64 bits and Windows 10 Pro x64)

    Line that causes the error is in the last IF of Sub HookListBoxScroll:
        mLngMouseHook = SetWindowsHookEx (WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)

    Can someone give me a clue as to what may be happening? with this configuration it works without problems: Excel Office 365 MSO (16.0.11001.20033) 32 bits and Windows 10 Home x64

    My code
    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 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 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 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 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 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 LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As Long
    #Else
    Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long
    #End If
            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 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 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
    

    Thursday, October 18, 2018 9:26 AM
  • Sorry for making infinite this thread. I have used the Peter Thornton code modified by jdubei and Ahmed Morsyy for the mouse wheel to work in all environments but Excel closes when putting the cursor over the control without giving an error. It only closes. (Excel 2016 MSO (16.0.10827.20150) 64 bits and Windows 10 Pro x64)

    Line that causes the error is in the last IF of Sub HookListBoxScroll:
        mLngMouseHook = SetWindowsHookEx (WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)

    Can someone give me a clue as to what may be happening? with this configuration it works without problems: Excel Office 365 MSO (16.0.11001.20033) 32 bits and Windows 10 Home x64

    Mario, 

    The code you posted fails to compile for me in x64 with a mismatch error on this line

    MouseProc = CallNextHookEx(mLngMouseHook, nCode, wParam, ByVal lParam)

    To fix change the return declaration of MouseProc from As Long to As Long for the #If VBA7 version, to match what CallNextHookEx returns.

    With that fix the code works for me in x64 Office. But x64 is extremely sensitive, it can work fine in most systems most of the time but fail in some for no obvious reason. In my apps I have made many changes to minimize such issues. (32x Office in Win64 is much more stable)

    Your problem -

    mLngMouseHook = SetWindowsHookEx (WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)

    As I say, that works for me and I don't know why it doesn't for you. The only thing that stands out is the '0'. Normally that should be OK and its Type will coerce to a Long but wouldn't include it like that. Try changing it to 0& which will explicitly change it from an Integer to a Long to match the dwThreadId declaration in the API

    Saturday, October 20, 2018 12:12 PM
    Moderator
  • Sorry for making infinite this thread. I have used the Peter Thornton code modified by jdubei and Ahmed Morsyy for the mouse wheel to work in all environments but Excel closes when putting the cursor over the control without giving an error. It only closes. (Excel 2016 MSO (16.0.10827.20150) 64 bits and Windows 10 Pro x64)

    Line that causes the error is in the last IF of Sub HookListBoxScroll:
        mLngMouseHook = SetWindowsHookEx (WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)

    Can someone give me a clue as to what may be happening? with this configuration it works without problems: Excel Office 365 MSO (16.0.11001.20033) 32 bits and Windows 10 Home x64

    Mario, 

    The code you posted fails to compile for me in x64 with a mismatch error on this line

    MouseProc = CallNextHookEx(mLngMouseHook, nCode, wParam, ByVal lParam)

    To fix change the return declaration of MouseProc from As Long to As Long for the #If VBA7 version, to match what CallNextHookEx returns.

    With that fix the code works for me in x64 Office. But x64 is extremely sensitive, it can work fine in most systems most of the time but fail in some for no obvious reason. In my apps I have made many changes to minimize such issues. (32x Office in Win64 is much more stable)

    Your problem -

    mLngMouseHook = SetWindowsHookEx (WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)

    As I say, that works for me and I don't know why it doesn't for you. The only thing that stands out is the '0'. Normally that should be OK and its Type will coerce to a Long but wouldn't include it like that. Try changing it to 0& which will explicitly change it from an Integer to a Long to match the dwThreadId declaration in the API

    Thank you very, very much Peter, declaring 0& the problem is solved:

        mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0&)

    Really Office 64 is extremely sensitive :) I have not a compile error, but I have changed your suggestion (Long to LongPtr) and it work

        #If VBA7 Then

            Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr

    Wednesday, October 24, 2018 9:41 AM
  • Hi Peter! i've been using some code of yours in my excel worksheet for making possible scrolling listbox controls in a Whorksheet (Not Userforms)

    It works fine but sometimes, unexpectedly and without showing any errors, excel chashes and stop working (While scrolling over a Listbox control).

    Here is the code:

    (MODULE CODE)

    Option Explicit
     
    Private Type POINTAPI
      X As Long
      Y As Long
    End Type
     
    Private Type MSLLHOOKSTRUCT
        pt As POINTAPI
        mouseData As Long
        flags As Long
        time As Long
        dwExtraInfo As Long
    End Type
     
    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
     
     
    Private Declare Function LBItemFromPt Lib "comctl32.dll" _
    (ByVal hLB As Long, ByVal ptx As Long, ByVal pty As Long, ByVal bAutoScroll As Long) As Long
     
    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
     
     
    Private lMouseHook As Long
    Private lListBoxhwnd As Long
    Public bHookSet As Boolean
    Private oListBox As MSForms.ListBox

    Sub HookListBox(ListBox As MSForms.ListBox)
        
        Dim tPt As POINTAPI
        
        Set oListBox = ListBox
        GetCursorPos tPt
        lListBoxhwnd = (WindowFromPoint(tPt.X, tPt.Y))
        PostMessage lListBoxhwnd, WM_LBUTTONDOWN, 0, 0
        If Not bHookSet Then
            lMouseHook = SetWindowsHookEx _
            (WH_MOUSE_LL, _
            AddressOf LowLevelMouseProc, GetAppInstance, 0)
            If lMouseHook <> 0 Then
                bHookSet = True
            End If
        End If
     
    End Sub



    Private Function LowLevelMouseProc _
    (ByVal nCode As Long, ByVal wParam As Long, _
    ByRef lParam As MSLLHOOKSTRUCT) As Long
     
        On Error Resume Next
        
        If (nCode = HC_ACTION) Then
            If WindowFromPoint _
                (lParam.pt.X, lParam.pt.Y) = lListBoxhwnd Then
                If wParam = WM_MOUSEWHEEL Then
                    LowLevelMouseProc = True
                    If lParam.mouseData > 0 Then
                        PostMessage _
                        lListBoxhwnd, WM_KEYDOWN, VK_UP, 0
                        PostMessage _
                        lListBoxhwnd, WM_KEYUP, VK_UP, 0
                    Else
                        PostMessage _
                        lListBoxhwnd, WM_KEYDOWN, VK_DOWN, 0
                        PostMessage _
                        lListBoxhwnd, WM_KEYUP, VK_UP, 0
                    End If
                    Exit Function
                End If
            Else
                    UnhookWindowsHookEx lMouseHook
                    bHookSet = False
            End If
        End If
        
        LowLevelMouseProc = _
        CallNextHookEx _
        (lMouseHook, nCode, wParam, ByVal lParam)
     
    End Function
     
    Private Function GetAppInstance() As Long
     
        GetAppInstance = GetWindowLong _
        (FindWindow("XLMAIN", Application.Caption), GWL_HINSTANCE)
     
    End Function

    (WHORKSHEET CODE, IN EVERY LISTBOX MOUSE MOVE EVENT)

    Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

     Call HookListBox(Sheets("OPERACIONES").ListBox2)
    End Sub

    I am Using Office 2007

    I would appreciate any help given

    Thank You!

    Friday, October 26, 2018 2:14 PM
  • Hi Peter! i've been using some code of yours in my excel worksheet for making possible scrolling listbox controls in a Whorksheet (Not Userforms)

    It works fine but sometimes, unexpectedly and without showing any errors, excel chashes and stop working (While scrolling over a Listbox control).

    Here is the code:

    (MODULE CODE)

    Option Explicit
     
    Private Type POINTAPI
      X As Long
      Y As Long
    End Type
     
    Private Type MSLLHOOKSTRUCT
        pt As POINTAPI
        mouseData As Long
        flags As Long
        time As Long
        dwExtraInfo As Long
    End Type
     
    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
     
     
    Private Declare Function LBItemFromPt Lib "comctl32.dll" _
    (ByVal hLB As Long, ByVal ptx As Long, ByVal pty As Long, ByVal bAutoScroll As Long) As Long
     
    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
     
     
    Private lMouseHook As Long
    Private lListBoxhwnd As Long
    Public bHookSet As Boolean
    Private oListBox As MSForms.ListBox

    Sub HookListBox(ListBox As MSForms.ListBox)
        
        Dim tPt As POINTAPI
        
        Set oListBox = ListBox
        GetCursorPos tPt
        lListBoxhwnd = (WindowFromPoint(tPt.X, tPt.Y))
        PostMessage lListBoxhwnd, WM_LBUTTONDOWN, 0, 0
        If Not bHookSet Then
            lMouseHook = SetWindowsHookEx _
            (WH_MOUSE_LL, _
            AddressOf LowLevelMouseProc, GetAppInstance, 0)
            If lMouseHook <> 0 Then
                bHookSet = True
            End If
        End If
     
    End Sub



    Private Function LowLevelMouseProc _
    (ByVal nCode As Long, ByVal wParam As Long, _
    ByRef lParam As MSLLHOOKSTRUCT) As Long
     
        On Error Resume Next
        
        If (nCode = HC_ACTION) Then
            If WindowFromPoint _
                (lParam.pt.X, lParam.pt.Y) = lListBoxhwnd Then
                If wParam = WM_MOUSEWHEEL Then
                    LowLevelMouseProc = True
                    If lParam.mouseData > 0 Then
                        PostMessage _
                        lListBoxhwnd, WM_KEYDOWN, VK_UP, 0
                        PostMessage _
                        lListBoxhwnd, WM_KEYUP, VK_UP, 0
                    Else
                        PostMessage _
                        lListBoxhwnd, WM_KEYDOWN, VK_DOWN, 0
                        PostMessage _
                        lListBoxhwnd, WM_KEYUP, VK_UP, 0
                    End If
                    Exit Function
                End If
            Else
                    UnhookWindowsHookEx lMouseHook
                    bHookSet = False
            End If
        End If
        
        LowLevelMouseProc = _
        CallNextHookEx _
        (lMouseHook, nCode, wParam, ByVal lParam)
     
    End Function
     
    Private Function GetAppInstance() As Long
     
        GetAppInstance = GetWindowLong _
        (FindWindow("XLMAIN", Application.Caption), GWL_HINSTANCE)
     
    End Function

    (WHORKSHEET CODE, IN EVERY LISTBOX MOUSE MOVE EVENT)

    Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

     Call HookListBox(Sheets("OPERACIONES").ListBox2)
    End Sub

    I am Using Office 2007

    I would appreciate any help given

    Thank You!

    Actually, the problem is when the mouse cursor leaves the Listbox control.

    While in there (The listbox), the scroll works perfectly.

    But if i move out the mouse cursor and scroll the wheel, it chashes.

    If i click in any other control like a textbox or a random cell in the worksheet, and then scroll, the problem does not occur.

    The event Lost_focus doesn't handle when i move the cursor out or the Listbox. I suppose that i need an event like "Mouse Leave" or similar to unhook the control....

    Any suggestions?

    Friday, October 26, 2018 4:27 PM
  • Francisco, I don't see anything obviously wrong with your code, not sure why it fails.  x32 is relatively stable compared to x64. However even in x32 a hook like this can crash Excel without warning if the callback is interrupted, say be stepping through, an error, or an issue elsewhere in your code.

    There shouldn't be any difference with the Listbox on a worksheet, but rather than finding the XLMAIN window get the XLMAIN >  XLDESK > EXCEL7 window for the sheet (a long shot but it might help, but look into the above first).

    In passing you don't need FindWindow to get the XLMAIN handle, in 2007 simply Application.hwnd. I know you've got 2007 but for 2013 and later with SDI start with the workbook.Application.Hwnd

    Friday, October 26, 2018 7:07 PM
    Moderator
  • Hi everyone,

    I work in a windows 10 pro system at 64bit and with Excel 2016 version. I implemented the code of Mario with the corrections that Peter suggest. I have a combobox in a userform and i want to use the scroll wheel for search the date inside a database of 5 years...

    Excel don't sand me message of error but its don't work. In particular when I use the scrollwheel in the combobox, is selected the first date of the list with every input (up and down scroll). I have the same problem with the code of the post of peter in 2008...

    Where is my error? I don't understand

    Thanks in advance.

    The code that i implemented is:

    (in the module)


    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 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 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 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 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 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 LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
    #Else
    Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
    #End If
            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 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 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

    (in the Form)


    Private Sub cmbbData_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HookListBoxScroll Me, Me.cmbbData
    End Sub
    Private Sub UserForm_Initialize()
    Dim i As Long
    Dim s As String
            s = "this is line "
            For i = 1 To 50
                            Me.cmbbData.AddItem s & i

            Next
    End Sub

    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
            UnhookListBoxScroll
    End Sub

                                  
    • Proposed as answer by Buse Cristian Thursday, February 14, 2019 1:10 PM
    • Unproposed as answer by Buse Cristian Thursday, February 14, 2019 1:10 PM
    Monday, November 19, 2018 10:00 AM
  • You could just hook the mouse and get the whole Userform to scroll. By this I mean, listboxes, comboboxes, textboxes, frames, multipages and the form itself. Check out my repository: https://github.com/cristianbuse/VBA-UserForm-MouseScroll that does just that. You only need to call 1 line of code to hook it up to any modal form. Enjoy!

    Thursday, February 14, 2019 1:18 PM
  • Hi Peter,

    I am using system "64"....

    I got problem with this.... please help me.

    Thank you

    <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">Function</span> CallNextHookEx <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">Lib</span> <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:#a31515">"user32"</span> ( _
                                                            <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">ByVal</span> hHook <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">As</span> <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">Long</span>, _
                                                            <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">ByVal</span> nCode <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">As</span> <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">Long</span>, _
                                                            <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">ByVal</span> wParam <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">As</span> <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">Long</span>, _
                                                            lParam <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">As</span> <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">Any</span>) <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">As</span> <span style="border:0px; font-weight:inherit; font-style:inherit; font-family:inherit; margin:0px; outline:0px; padding:0px; color:blue">Long</span>
    

    Tuesday, March 12, 2019 4:17 AM
  • Thank you sir, it works perfectly
    Saturday, July 25, 2020 4:03 AM