Determine Mouse Scroll Wheel Rotation in VBA for Excel (64-bit and 32-bit)

[Spork Schivago]

Hi!

I am having a hard time getting this code running properly. I have searched the net for many hours. I want a standard module that will detect if the mouse wheel is scrolled up or down. Essentially, I am trying to change how many rows get scrolled at a time.

Here is the code I have currently in Module1. I am running Microsoft 365 E3, which includes a copy of Office 365 E3.

Option Explicit
Private Type POINTAPI
    X As Long
    Y As Long
End Type

'64-bit
#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long

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


    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" _ 
        (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, _
         ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _ 
        (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, _ 
         ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _ 
        (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, _ 
         ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long

    Private XlDeskHwnd As LongPtr
    Private WbkHwnd As LongPtr
'32-bit
#Else
    Private Declare Function SetTimer Lib "user32" _ 
    (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, _ 
     ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" _ 
    (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long


    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" _ 
    (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, _ 
     ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _ 
    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _ 
     ByVal lParam As Long) As Long
    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
    Private Declare Function WaitMessage Lib "user32" () As Long
    
    Private XlDeskHwnd As Long
    Private WbkHwnd As Long
#End If

Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const PM_REMOVE = &H1

Private bCancel As Boolean
Private scrollRowNumber As Integer

Public Sub Start()
    bCancel = False
    scrollRowNumber = 3
    Call Setup_ScrollWheelRows(scrollRowNumber)
End Sub

Public Sub Finish()
    bCancel = True
End Sub

Private Sub Auto_Close()
    Call Finish
End Sub

Private Sub Setup_ScrollWheelRows(scrollRowNumber)
    Dim tMSG As MSG
    Dim bIsCompatibilityMode As Boolean
    Dim sExcel8CompatibilityModeCaption As String


    If Val(Application.Version) >= 16 Then ' >= Microsoft 365 E3
        bIsCompatibilityMode = CallByName(Workbooks(1), "Excel8CompatibilityMode", VbGet)
        If bIsCompatibilityMode Then
            If Application.International(xlCountryCode) = 33 Then 'French
                sExcel8CompatibilityModeCaption = " [Mode de compatibilité]"
            Else 'English
                sExcel8CompatibilityModeCaption = " [Compatibility Mode]"
            End If
        End If
    End If


    XlDeskHwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    WbkHwnd = FindWindowEx(XlDeskHwnd, 0, "EXCEL7", Workbooks(1).Name & sExcel8CompatibilityModeCaption)
    If WbkHwnd = 0 Then
        WbkHwnd = FindWindowEx(XlDeskHwnd, 0, "EXCEL7", Workbooks(1).Name & " " & sExcel8CompatibilityModeCaption)
    End If
    
    If WbkHwnd Then
        Do
            WaitMessage
            If PeekMessage(tMSG, WbkHwnd, 0, 0, PM_REMOVE) Then
                Select Case tMSG.message
                    Case WM_MOUSEWHEEL
                        MsgBox "tMSG.wParam: " & tMSG.wParam
                        
                        If tMSG.wParam > 0 Then
                            MsgBox "Scroll up " & scrollRowNumber
                            ActiveWindow.SmallScroll up:=scrollRowNumber
                        Else
                            MsgBox "Scroll down " & scrollRowNumber
                            ActiveWindow.SmallScroll down:=scrollRowNumber
                        End If
                    Case Else
                        PostMessage tMSG.hwnd, tMSG.message, tMSG.wParam, tMSG.lParam
                 End Select
            End If
            DoEvents
        Loop Until bCancel
    Else
        MsgBox "Not WbkHwnd"
    End If
End Sub

From where I obtained the code example from, it was my impression that if the wheel was scrolled one way, tMSG.wParam would be positive, and if scrolled the other way, it would be negative. This does not seem to be the case though. The internet shows lParam might contain the data I am looking for. I have tried many incorrect things. tMSG.lParam in it's current state does not appear to contain ever any negative numbers either.

I realize wParam and lParam are pointers and I am thinking in the code, all I am doing is reading an address, not the value stored at that address. It has been a very long time since I wrote in VB (back then, we had VB6!), although I am pretty fluent in C. Any help would be greatly appreciated.

Thank you!!!!

 

[z00bs]

I want to detect when the user mouse-scrolls the sheet.

 

[Jaafar Tribak]

I want to detect when the user mouse-scrolls the sheet.

Workbook example


See if this works for you :

Code goes in the ThisWorkbook Module.

Option Explicit

Private Enum eSCROLL_DIR
    Up
    Down
End Enum

Private Type POINTAPI
  x As Long
  y As Long
End Type

#If VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type

    #If Win64 Then
       Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr

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

    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal Wparam As Long, ByVal lParam As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    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
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
#End If

Private bStop As Boolean



Private Sub Workbook_Activate()
    EnableMouseScroll = True
End Sub

Private Sub Workbook_Deactivate()
    EnableMouseScroll = False
End Sub


Private Property Let EnableMouseScroll(ByVal Enable As Boolean)

    Const WM_MOUSEWHEEL = &H20A
    Const WHEEL_DELTA = 120
    Const PM_REMOVE = &H1
    Const PM_NOYIELD = &H2
    Const GW_CHILD = 5

    #If VBA7 Then
        Dim hDesk As LongPtr, hBook As LongPtr, hScrollBar As LongPtr
    #Else
        Dim hDesk As Long, hBook As Long, hScrollBar As Long
    #End If
   
    Dim tMsg As MSG, tCurPos As POINTAPI, eScrollDir As eSCROLL_DIR, bCancel As Boolean


    hDesk = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hBook = FindWindowEx(hDesk, 0, "EXCEL7", vbNullString)
    hScrollBar = GetNextWindow(FindWindowEx(hBook, 0, "NUIScrollbar", "Vertical"), GW_CHILD)

    If Enable = False Then
        bStop = True
    End If
       
    If Enable Then
   
        bStop = False
        Do
            Call GetCursorPos(tCurPos)
           
            #If Win64 Then
                Dim lPt As LongPtr
                Call CopyMemory(lPt, tCurPos, LenB(lPt))
                If WindowFromPoint(lPt) = hBook Or WindowFromPoint(lPt) = hScrollBar Then
            #Else
                If WindowFromPoint(tCurPos.x, tCurPos.y) = hBook Or WindowFromPoint(tCurPos.x, tCurPos.y) = hScrollBar Then
            #End If
           
                    Call WaitMessage
                    If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE + PM_NOYIELD) Then
                        #If Win64 Then
                            If HighWord64(tMsg.wParam) = WHEEL_DELTA Then
                        #Else
                            If HighWord32(tMsg.wParam) = WHEEL_DELTA Then
                        #End If
                            eScrollDir = Up
                    Else
                            eScrollDir = Down
                    End If
                   
                    bCancel = False
                    Call Workbook_Before_Mouse_Sroll(eScrollDir, bCancel)
                   
                    If Not bCancel Then
                        If eScrollDir = Up Then
                            ActiveWindow.SmallScroll Up:=1
                        Else
                            ActiveWindow.SmallScroll Down:=1
                        End If
                        'Call PostMessage (tMsg.hwnd, tMsg.message, tMsg.wParam, tMsg.lParam)
                        End If
                    End If
                   
            End If
           
            DoEvents
            If bStop = True Then Exit Do
        Loop
       
    End If
       
End Property


Private Function HighWord32(ByVal wParam As Long) As Integer
    Call CopyMemory(HighWord32, ByVal VarPtr(wParam) + 2, 2)
End Function

Private Function HighWord64(ByVal wParam As LongPtr) As Long
    Call CopyMemory(HighWord64, ByVal VarPtr(wParam) + 2, 4)
End Function



'___________________________________PSEUDO-EVENT_________________________________________.
Private Sub Workbook_Before_Mouse_Sroll(ByVal ScrollDirection As eSCROLL_DIR, ByRef Cancel As Boolean)

    Debug.Print "MouseWheel Scrolling: " & IIf(ScrollDirection = Up, "UP", "DOWN")
   
    'Can't mouse-scroll past row 20 !
    If ActiveWindow.ScrollRow >= 20 And ScrollDirection = Down Then
        Cancel = True
        MsgBox "Stop"
    End If
   
End Sub

PS: The code intercepts the MouseWheel scrolling via the PeekMessage API. Unfortunately, using the PeekMessage approach has two issues :
1- Doesnt work fast enough to catch fast mouse scroll movements (works well with normal mouse scroll)
2- It runs inside a continious loop which puts a heavy strain on the application.

The only accurate\fast method and that which doesnt run a heavy loop is AFAIK, by installing a windows mouse hook but this should be run either from a dll or from a second excel instance in order for it to be safe.

 

[YasserKhalil]

@Jafaar
Thanks a lot, my friend. What's the benefit from such a code in practical use?

 

[z00bs]

@Jaafar Tribak Thanks. Your code works with the mentioned limitations (kinda the same as the original poster's code). Coming from a non windows dev background the issues I'm facing here feel strange. But thank you anyways.

 

[Jaafar Tribak]

@Jafaar
Thanks a lot, my friend. What's the benefit from such a code in practical use?

Excel doesn't fire an event when a worksheet is scrolled... This code permits the user to intercept this event.

 

[YasserKhalil]

I know what the code does. But I need a practical example of such an event. Do we really need such events to be there?

 

[Jaafar Tribak]

I know what the code does. But I need a practical example of such an event. Do we really need such events to be there?

An example is what the OP is asking- He wants to change how many rows get scrolled at a time with the mousewheel... or one may want to ensure that the sheet is not scrolled past a certain row etc ...

Obviously, this is not of much use as the user can still scroll by clicking the sheet scrollbars or by pressing the keyboard arrow keys and these won't be intercepted unless you also code for the WM_VSCROLL window message and the same for the arrow keys.

 

[RoryA]

And it's a lot simpler to just set the ScrollArea.

 

[Jaafar Tribak]

@Jaafar Tribak Thanks. Your code works with the mentioned limitations (kinda the same as the original poster's code). Coming from a non windows dev background the issues I'm facing here feel strange. But thank you anyways.

The code in post#12 does show that the high order of the wParam argument is positive (120) when mouse-scrolling UP and negative (-120) when scrolling DOWN just as expected and as per the documentation.


Just add a Debug.Print as follows to see it :

Call WaitMessage
If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE + PM_NOYIELD) Then
    #If Win64 Then
        Debug.Print HighWord64(tMsg.wParam)  ' <== Returns (120) if mouse-scroll UP and (-120) if DOWN     x64bit
        If HighWord64(tMsg.wParam) = WHEEL_DELTA Then
    #Else
        Debug.Print HighWord32(tMsg.wParam) ' <== Returns (120) if mouse-scroll UP and (-120) if DOWN     x32bit
        If HighWord32(tMsg.wParam) = WHEEL_DELTA Then
    #End If
        eScrollDir = Up
Else
        eScrollDir = Down
End If

 

[Jaafar Tribak]

And it's a lot simpler to just set the ScrollArea.

True. However,setting the sheet ScrollArea won't help if for some reason, you need to run code when mouse-scrolling or you try to change how many rows get scrolled at a time (like what the OP was asking)