Announcement

Collapse
No announcement yet.

Mouse Wheel scroll userform

Collapse
This topic is closed.
X
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Mouse Wheel scroll userform



    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.

  • #2
    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
    Rory
    Theory is when you know something, but it doesnít work. Practice is when something works, but you donít know why. Programmers combine theory and practice: nothing works and they donít know why

    Comment


    • #3
      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.

      Comment


      • #4
        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
        Rory
        Theory is when you know something, but it doesnít work. Practice is when something works, but you donít know why. Programmers combine theory and practice: nothing works and they donít know why

        Comment


        • #5
          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.
          Last edited by Rocky13; December 10th, 2013, 18:43.

          Comment


          • #6
            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

            Comment


            • #7
              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.
              AAE
              ----------------------------------------------------

              Forum Rules | Message to Cross Posters | How to use Tags

              Comment


              • #8
                Re: Mouse Wheel scroll userform

                Originally posted by Rocky13 View Post
                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.
                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

                Comment


                • #9


                  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.
                  Hope that Helps

                  Roy

                  New users should read the Forum Rules before posting

                  For free Excel tools & articles visit my web site

                  RoyUK's Web Site

                  royUK's Database Form

                  Where to paste code from the Forum

                  About me.

                  Comment

                  Working...
                  X