Updated Userform Mouse Scroll Wheel Code for VBA7/Prior, Win64/Win32

[Legacy 471763]

Not sure who originally created the mouse scroll wheel program for Excel Userforms, but I was having alot of issues with the form crashing, especially while debugging or when the form became large. Since I was creating a tool to be used by other's in my company as well, I needed to resolve this. I could never find an updated one that (correctly!) accounted for VBA7 & prior versions, as well as Win32 & Win64. Alot of versions with the wrong variables being changed to LongPtr.

Anyways, I spent a while one night updating the program and it has worked quite well for myself and other's without crashing. Also changed the low level mouse proc program to unhook the mouse if the userform isn't the current window, which fixed the debug issue I was running into.

Hope it helps someone else. Let me know if anyone see's something else wrong.

Thanks

'Will compile in 32 & 64 bit.
Option Explicit
#If VBA7 Then
   Private Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
   Private Declare PtrSafe Function GetForegroundWindow Lib "USER32" () As LongPtr
   Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
   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 UnhookWindowsHookEx Lib "USER32" (ByVal hHook As LongPtr) As Long
   Private Declare PtrSafe Function CallNextHookEx Lib "USER32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) 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 GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
   #End If
#Else
   Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   Private Declare Function GetForegroundWindow Lib "USER32" () As Long
   Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length 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 UnhookWindowsHookEx Lib "USER32" (ByVal hHook 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 GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
#End If

Private Type POINTAPI
   j 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 Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private Const GWL_HINSTANCE = (-6)

Public Const nMyControlTypeNONE = 0
Public Const nMyControlTypeUSERFORM = 1
Public Const nMyControlTypeFRAME = 2
Public Const nMyControlTypeCOMBOBOX = 3
Public Const nMyControlTypeLISTBOX = 4
Public Const nMyControlTypeMULTIPAGE = 5

#If VBA7 Then
   Private hhkLowLevelMouse As LongPtr
#Else
   Private hhkLowLevelMouse As Long
#End If

Private udtlParamStuct As MSLLHOOKSTRUCT

Public myGblUserForm As UserForm
Public myGblControlObject As Object
Public iGblControlType As Long

#If VBA7 Then
   Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
#Else
   Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
#End If

   'Parses the .MouseData parameter of the lParam parameter and stores in the virtual memory address for the udtlParamStruct
   CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
   GetHookStruct = udtlParamStuct
   
End Function

#If VBA7 Then
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

   Dim iDirection As Long
   
   On Error Resume Next
   
   'If the current window isn't the UserForm, unhook the mouse.
   If GetForegroundWindow <> FindWindow("ThunderDFrame", myGblUserForm.Caption) Then
       If hhkLowLevelMouse <> 0 Then
           UnhookWindowsHookEx hhkLowLevelMouse 'unhook the window
       End If
       Exit Function
   End If
   
   'HC_ACTION: The wParam and lParam parameters contain information about a mouse message.
   'nCode = The hook code passed to the current hook procedure to determine how to process the message.
   If (nCode = HC_ACTION) Then
      If wParam = WM_MOUSEWHEEL Then
         iDirection = GetHookStruct(lParam).mouseData 'Determine if user scrolled up or down
         Call ProcessMouseWheelMovement(iDirection) 'Determine what the mouse wheel action does.
         LowLevelMouseProc = True '(True = -1, False = 0)
      End If
      Exit Function
   End If

   'If nCode is less than zero, the hook procedure must pass the message to the CallNextHookEx function without further processing.
   'CallNextHookEx = Passes the hook information to the next hook procedure in the current hook chain.
   LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function

Sub Hook_Mouse()

   'Default value of hhkLowLevelMouse = 0. hhkLowLevelMouse is only non-zero if the Hook_Mouse sub was called and successfully hooked to a window.
   'WH_MOUSE_LL = Installs a hook procedure that monitors low-level mouse input event.
   'LowLevelMouseProc = The system calls this function every time a new mouse input event.
   'GetWindowLongPtr = A handle to the DLL containing the hook procedure pointed to.
   'If the function succeeds, hhkLowLevelMouse = the handle to the hook procedure.
   
   #If VBA7 Then
      If hhkLowLevelMouse < 1 Then
          
         hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLongPtr(FindWindow("ThunderDFrame", myGblUserForm.Caption), GWL_HINSTANCE), 0)
      End If
   #Else
      If hhkLowLevelMouse < 1 Then
         hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLong(FindWindow("ThunderDFrame", myGblUserForm.Caption), GWL_HINSTANCE), 0)
      End If
   #End If
   
End Sub

Sub UnHook_Mouse()
   'Default value of hhkLowLevelMouse = 0. hhkLowLevelMouse is only non-zero if the Hook_Mouse sub was called and successfully hooked to a window.
   If hhkLowLevelMouse <> 0 Then
      UnhookWindowsHookEx hhkLowLevelMouse 'hhkLowLevelMouse = the handle to the hook procedure.
      hhkLowLevelMouse = 0
      Set myGblControlObject = Nothing
      Set myGblUserForm = Nothing
   End If
End Sub

Public Sub ProcessMouseWheelMovement(ByVal iDirection As Long)

   Dim i As Long
   Dim X As Long
   Dim iMultiplier As Long 'Multiplier used to inrease magnitude of resulting scroll action.
   
   Select Case iGblControlType
   
      Case nMyControlTypeUSERFORM
         iMultiplier = 3
         If iDirection > 0 Then
            For i = 1 To iMultiplier
               myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
            Next i
         Else
            For i = 1 To iMultiplier
               myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
            Next i
         End If
      Case nMyControlTypeFRAME
         iMultiplier = 5
         If iDirection > 0 Then
            For i = 1 To iMultiplier
               myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
            Next i
         Else
            For i = 1 To iMultiplier
               myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
            Next i
         End If
         
      Case nMyControlTypeCOMBOBOX
         With myGblControlObject
            If iDirection > 0 Then
               .TopIndex = .TopIndex - 1
            Else
               .TopIndex = .TopIndex + 1
            End If
         End With
         
      Case nMyControlTypeLISTBOX
         With myGblControlObject
            If iDirection > 0 Then
               X = .TopIndex - 5
               .TopIndex = IIf(X < 0, 0, X)
            Else
               .TopIndex = .TopIndex + 10
            End If
         End With
         
      Case nMyControlTypeMULTIPAGE
         iMultiplier = 3
         If iDirection > 0 Then
            For i = 1 To iMultiplier
               myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
            Next i
         Else
            For i = 1 To iMultiplier
               myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
            Next i
         End If
         
   End Select
End Sub

 

[Jaafar Tribak]

Djsi222​

Thanks for your contribution.


A couple of observations :

1-The code won't compile in 32bit excel 2010 and later versions... You will need to do your conditional compilation with #VBA7 rather than with #Win64 because of the GetWindowLong API.

Alternatively, you could just use GetModuleHandle(VBNullString) instead of GetWindowLongPtr(FindWindow("ThunderDFrame", myGblUserForm.Caption), GWL_HINSTANCE)
Or
Application.HinstancePtr
for 64bit excel and
Application.Hinstance
for 32bit excel.

Also, you need to store the userform in the myGblUserForm variable before setting the mouse hook .
Pass the userform object as an argument to the Hook_Mouse SUB.

All the above will look something like this :

Sub Hook_Mouse(ByVal UForm As UserForm)

   Set myGblUserForm = UForm

   #If VBA7 Then
      If hhkLowLevelMouse < 1 Then
         hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLongPtr(FindWindow("ThunderDFrame", myGblUserForm.Caption), GWL_HINSTANCE), 0)
      End If
   #Else
      If hhkLowLevelMouse < 1 Then
         hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLong(FindWindow("ThunderDFrame", myGblUserForm.Caption), GWL_HINSTANCE), 0)
      End If
   #End If

End Sub

... and then set the mouse hook in the UserForm Module like this:

Option Explicit

Private Sub UserForm_Initialize()
    Hook_Mouse Me
End Sub

Private Sub UserForm_Terminate()
    UnHook_Mouse
End Sub

2- Don't completely remove the mouse hook when the userform is not currently the active window. Just exit the callback so the mousewheel stays hooked when getting back to the userform.

   'If the current window isn't the UserForm, unhook the mouse.
   If GetForegroundWindow <> FindWindow("ThunderDFrame", myGblUserForm.Caption) Then
'       If hhkLowLevelMouse <> 0 Then
'           UnhookWindowsHookEx hhkLowLevelMouse 'unhook the window
'            hhkLowLevelMouse = 0
'           Debug.Print myGblUserForm.Caption
'       End If
       Exit Function
   End If

3- The ProcessMouseWheelMovement SUB didn't work for me as the iGblControlType variable always evaluates to 0 no matter where the mouse pointer is located when mousescrolling.
You will need to somehow determine the current object\control currently under the mouse pointer either by dynamically changing the value of the iGblControlType variable inside each control mouse_move event handler (Which is, I think, what you are doing) or, for a more generic solution, by using the WindowFromPoint API and\or the IAccessible.Location Method.

4- Since your code uses a Windows Hook, any unhandled error while the hook is installed will crash the entire application (particularly if the UserForm is Modeless). So propper and carefull error handling must be implemented throughout when using this code.

There is a much safer and more stable atlernative to using a windows hook which won't crash excel should an error occur and that is to use the PeekMessage\GetMessage APIs for intercepting the mousewheel scrolls... If you search the board for "WM_MOUSEWHEEL", you will find many examples.



.