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

 

[Yongle]

a simpler approach for you to consider ...

Double-Click event to scroll down (20 rows)
Right-Click event to scroll up (20 rows)

Test in a new sheet

Place in sheet module

Option Explicit
Const scroll = 20
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If MsgBox("Scroll down?", vbYesNo, "") = vbYes Then
        Cancel = True
        ActiveWindow.ScrollRow = WorksheetFunction.Min(Target.Row + scroll, Rows.Count - 20)
    End If
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If MsgBox("Scroll up?", vbYesNo, "") = vbYes Then
        Cancel = True
        ActiveWindow.ScrollRow = WorksheetFunction.Max(Target.Row - scroll, 1)
    End If
End Sub

 

[Yongle]

to apply suggestion in post#2 to the whole workbook

Place in ThisWorkbook module

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If MsgBox("Scroll down?", vbYesNo, "") = vbYes Then
        Cancel = True
        ActiveWindow.ScrollRow = WorksheetFunction.Min(Target.Row + scroll, Rows.Count - 20)
    End If
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If MsgBox("Scroll up?", vbYesNo, "") = vbYes Then
        Cancel = True
        ActiveWindow.ScrollRow = WorksheetFunction.Max(Target.Row - scroll, 1)
    End If
End Sub

which could both be tailored to exclude or include specific sheets if required

 

[Yongle]

oops
I missed pasting this line in post#3
- must be placed at top of ThisWorkbook module before both subs

Const scroll = 20

 

[Spork Schivago]

a simpler approach for you to consider ...

Double-Click event to scroll down (20 rows)
Right-Click event to scroll up (20 rows)

Test in a new sheet

Place in sheet module

Option Explicit
Const scroll = 20
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If MsgBox("Scroll down?", vbYesNo, "") = vbYes Then
        Cancel = True
        ActiveWindow.ScrollRow = WorksheetFunction.Min(Target.Row + scroll, Rows.Count - 20)
    End If
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If MsgBox("Scroll up?", vbYesNo, "") = vbYes Then
        Cancel = True
        ActiveWindow.ScrollRow = WorksheetFunction.Max(Target.Row - scroll, 1)
    End If
End Sub

I am sorry for the long delay in my response. I was very sick for a while. I do not think I was very clear with what I need to accomplish. I will try to explain a bit more clear like.

I own a business. I have a company header with our company name, logo, etc. in various Microsoft templates (Excel, Word, Access). For Excel, this header takes up a good amount of screen space. It uses rows 1 through 3. Row 4 is the first available row for data.

On Row 4, I have a table header. Underneath Row 4 is the data for the table. I am trying to write VBA code so when a employee scrolls down using the mouse wheel, the company header will scroll off the page and it will Freeze Row 4. This wasn't too hard to accomplish, however, it did not flow. It was scrolling too many rows at one time when I used the mouse wheel. My code would freeze Row 4, but before doing so, it would jump a row down or up because when I scrolled using the wheel, for example, it was scrolling too many rows at one time.

When I scroll back up, my code checks to see what the top row is and if it's proper, it will unfreeze Row 4 and allow the scroll, so the company header can get scrolled to.

I hope this makes things a bit clearer. My current code (not showed here) is modified to accomplish what I want, but I am not so certain it works as intended.

The issue is with the code I posted. This section to be exact:

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

tMSG.wParam, from what I was reading on the site that had the sample code, tMSG.wParam should be less than 0 (negative) if scrolled down, positive if scrolled up. However, from my examples, this is not the case at all. This is the current section of code where I could get it work as intended:

If tMSG.wParam \ 65336 \ 120 = 1 Then
    MsgBox "Scroll up " & scrollRowNumber
    On_Sheet_V_Scroll (bCancel)
    ActiveWindow.SmallScroll up:=scrollRowNumber
Else
    MsgBox "Scroll down " & scrollRowNumber
    On_Sheet_V_Scroll (bCancel)
    ActiveWindow.SmallScroll down:=scrollRowNumber
End If

That code to me does not look quiet right there. What really worries me is I'm thinking the original code probably worked on either some earlier version of Windows or some earlier version of Excel. Backwards compatibility for my code is important with OS and Excel versions, 32-bit, 64-bit. I cannot guarentee the Excel sheet will always be opened on Windows 10 Enterprise using the Microsoft 365 E3 Excel program running on a 64-bit processor.

Thanks!

 

[Yongle]

Am I missing something?

This seems to achive what you want - freeze at row 4 with option to toggle hidden status of rows 1:3

Test as follows
- ensure sheet is frozen at row 4
- insert the code
- click on any cell in row 4
- scroll etc
- click on any cell in row 4
- scroll


Place in ThisWorkbook module to apply to whole workbook

 Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Row = 4 Then
        With Rows("1:3")
            If .Hidden Then .Hidden = False Else .Hidden = True
        End With
    End If
End Sub

OR Place in sheet module to make it apply to only one sheet

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Row = 4 Then
        With Rows("1:3")
            If .Hidden Then .Hidden = False Else .Hidden = True
        End With
    End If
End Sub

 

[Spork Schivago]

Yup, that code, from looking at it, will only work if an employee or a client clicks one of the rows, which is not what I want. The code I currently showed allows me to hide rows 1 and 3 when the user scrolls down to where they would normally scroll off the screen, and locks row 4. And then does the opposite when they scroll back up.

From what I've read from where the original code came from though, when the mouse wheel is scrolled one way, it should return a negative value. When it's rolled the other way, a positive value.

For whatever reasons, on the test machine, that is not what is happening. I have adapted the code to where it works the way I want it to, but I am worried it will not work properly on other machines. The code was on a site and appeared to work at some point in time unmodified, which implies on some OS or some previous version of excel, when the wheel was spun the one way, it did in fact return a negative value.

 

[Jaafar Tribak]

If tMSG.wParam \ 65336 \ 120 = 1 Then    MsgBox "Scroll up " & scrollRowNumber
    On_Sheet_V_Scroll (bCancel)
    ActiveWindow.SmallScroll up:=scrollRowNumber
Else
    MsgBox "Scroll down " & scrollRowNumber
    On_Sheet_V_Scroll (bCancel)
    ActiveWindow.SmallScroll down:=scrollRowNumber
End If

That code looks correct to me ... it gets the high order of the wparam parameter as per the MS documentation and should work accross diff platforms.

 

[z00bs]

@Jaafar Tribak The code that looks correct to you doesn't seem to work if the user scrolls up 'fast'. In this case wParam / 65336 results in different values > 120. According to the documentation it should be positive or negative, which is never the case (as mentioned by Spork). Is there anything we're missing?

I'm using Excel 16.0.12827.20236 64-Bit.

 

[Jaafar Tribak]

@Jaafar Tribak The code that looks correct to you doesn't seem to work if the user scrolls up 'fast'. In this case wParam / 65336 results in different values > 120. According to the documentation it should be positive or negative, which is never the case (as mentioned by Spork). Is there anything we're missing?

I'm using Excel 16.0.12827.20236 64-Bit.

What do you want this for ? Do you just want to detect when the user mouse-scrolls over the worksheet or do you want to scroll a listbox or ... etc ?