Mouse Wheel scroll userform

Rocky13 · Dec 2nd 2013

Hi,

I was wondering if its actually possible to make the userform scroll using the mouse wheel.

I am able to find code by Peter Thornton that does this for listboxes and comboboxes by calling a windows api but am yet to find anything that works for the whole userform.

If anyone knows a way I would greatly appreciate the help.

**rory** · Dec 2nd 2013

Re: Mouse Wheel scroll userform

Based on Peter's code, and assuming you have your form set with appropriate scrollheight/height properties:

Userform code:

Code

Private Sub UserForm_Initialize()
   HookFormScroll Me
End Sub




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

Normal module:

Code

Option Explicit
' Based on code from Peter Thornton here:
' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
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 Const cSCROLLCHANGE        As Long = 10


Private mLngMouseHook              As Long
Private mFormHwnd                  As Long
Private mbHook                     As Boolean
Dim mForm                          As Object




Sub HookFormScroll(oForm As Object)
   Dim lngAppInst                  As Long
   Dim hwndUnderCursor             As Long


   Set mForm = oForm
   hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
Debug.Print "Form window: " & hwndUnderCursor
   If mFormHwnd <> hwndUnderCursor Then
      UnhookFormScroll
Debug.Print "Unhook old proc"
      mFormHwnd = hwndUnderCursor
      lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
      If Not mbHook Then
         mLngMouseHook = SetWindowsHookEx( _
                         WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
         mbHook = mLngMouseHook <> 0
         If mbHook Then Debug.Print "Form hooked"
      End If
   End If
End Sub


Sub UnhookFormScroll()
   If mbHook Then
      UnhookWindowsHookEx mLngMouseHook
      mLngMouseHook = 0
      mFormHwnd = 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
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
   MouseProc = CallNextHookEx( _
               mLngMouseHook, nCode, wParam, ByVal lParam)
   Exit Function
errH:
   UnhookFormScroll
End Function

Display More

Rocky13 · Dec 7th 2013

Re: Mouse Wheel scroll userform

rory

Thank you that works like a charm.

The only thing I changed was cSCROLLCHANGE from 10 to 20 to make it scroll down a bit quicker.

**rory** · Dec 9th 2013

Re: Mouse Wheel scroll userform

Re your PM (In future, please post any follow-up questions in the thread ;)), to avoid affecting other programs, try this version:

Code

Option Explicit
' Based on code from Peter Thornton here:
' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
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
Declare Function GetActiveWindow Lib "user32" () 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 Const cSCROLLCHANGE        As Long = 10


Private mLngMouseHook              As Long
Private mFormHwnd                  As Long
Private mbHook                     As Boolean
Dim mForm                          As Object




Sub HookFormScroll(oForm As Object)
   Dim lngAppInst                  As Long
   Dim hwndUnderCursor             As Long


   Set mForm = oForm
   hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
Debug.Print "Form window: " & hwndUnderCursor
   If mFormHwnd <> hwndUnderCursor Then
      UnhookFormScroll
Debug.Print "Unhook old proc"
      mFormHwnd = hwndUnderCursor
      lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
      If Not mbHook Then
         mLngMouseHook = SetWindowsHookEx( _
                         WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
         mbHook = mLngMouseHook <> 0
         If mbHook Then Debug.Print "Form hooked"
      End If
   End If
End Sub


Sub UnhookFormScroll()
   If mbHook Then
      UnhookWindowsHookEx mLngMouseHook
      mLngMouseHook = 0
      mFormHwnd = 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 GetActiveWindow = mFormHwnd Then


         If wParam = WM_MOUSEWHEEL Then
            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
End Function

Display More

Rocky13 · Dec 10th 2013

Re: Mouse Wheel scroll userform

Nice that works.

There is only a slight bug for some people, where they scroll around and then sometimes it just stops scrolling, this also happened with the old code. It would appear it only happens when you scroll up. This doesn't happen to me so I can only guess its a windows version issue or mouse type issue lol.

I am still surprised this kind of stuff doesn't exist naturally in newer versions of excel.

lapo1234 · Apr 28th 2014

Re: Mouse Wheel scroll userform

When I run this I am getting a compile error: for this statement: Declare Function GetActiveWindow Lib "user32" () As Long

AAE · Apr 28th 2014

Re: Mouse Wheel scroll userform

lapo1234,

Posting questions in threads started by others is known as thread hijacking.
Always start a new thread for your questions and include links to any other threads you find helpful to clarify your needs.

dickyjim · Sep 26th 2014

Re: Mouse Wheel scroll userform

Quote from Rocky13;693489

Hi,

I was wondering if its actually possible to make the userform scroll using the mouse wheel.

I am able to find code by Peter Thornton that does this for listboxes and comboboxes by calling a windows api but am yet to find anything that works for the whole userform.

If anyone knows a way I would greatly appreciate the help.

Display More

Good day all. I am new to this group but have found it to be very informative. I am trying to use the userform mouse wheel scroll code in an MS Word 2010 form. When I try to compile the program, it gets stuck on the Application.Max and Application.Min properties. These don't seem to be available in MS Word. I would also like to adapt this code for use in a frame within the user form. Any help here would be greatly appreciated,

Thanks,

Rich

**royUK** · Sep 26th 2014

Re: Mouse Wheel scroll userform

Welcome to the Forum

Please start your own post. Posting in another member's Thread is known as hijacking and is not allowed here. By all means add a link to a Thread that may be related to your question.

Mouse Wheel scroll userform

Participate now!

Share