VBA To replace Mousewheel Scroll Event to go down or up one row isntead of 3

[Bill Bisco]

Dear all,

I want to write VBA Code that will replace the Regular Mousewheel Scroll Event and go up or down 1 row instead of whatever the Windows Mouswheel Scroll settings are


This is the code to Scroll down or up<code> </code><code>ActiveWindow.SmallScroll down:=1
<code>ActiveWindow.SmallScroll up:=1

What VBA Code would I use to modify the OnScroll event?

Thanks,

Bill</code></code>

 

[RickXL]

Hi,

The Scroll Wheel Settings are controlled via the Control Panel. Go to Devices-->Mouse & touchpad.

This setting is saved in the registry and you can change Registry settings with VBA.

Caveats:

► I am assuming a Windows machine.
► Some users may not take kindly to having their Registry settings changed for them.
► If you make a mistake you may damage the operation of their PC.

Here is some code to change the WheelScrollLines setting to "1". The default is "3". You should probably read in the existing setting and restore it before your macro finishes.

Sub WheelScrollLinesSet()
    With CreateObject("WScript.Shell")
        .RegWrite "HKCU\Control Panel\Desktop\WheelScrollLines", "1", "REG_SZ"
    End With
End Sub

The next macro will read the current value into a variable called Value. That can then be used to save the existing value somewhere.

Sub WheelScrollLinesGet()
    Dim Value As String
    With CreateObject("WScript.Shell")
        Value = .Regread("HKCU\Control Panel\Desktop\WheelScrollLines")
    End With
End Sub

Regards,

 

[RickXL]

Apologies.

I thought I had a solution but it does everything except work.

The Scroll Wheel Settings are controlled via the Control Panel. Go to Devices-->Mouse & touchpad. I thought I would be able to change it by changing the Registry Settings. While I can change the number it does not affect Windows.

A call to the Windows API may be required.

Sorry,

 

[RickXL]

OK, Plan B ...

It seems that the Windows SystemParametersInfo API is required. Some details about it are available here: https://support.microsoft.com/en-us/kb/97142

Basically, you need toDeclare the SystemParametersInfo Function so that VBA can use it. It also needs some constants. You don't have to be quite as long-winded as shown here but it is consistent with all the documentation.

The caveats above still apply.

I have included the code to display the new setting in a Message Box in case you ever need to read the current setting. It is commented out at the end.

This works on my Windows 10 64bit, Excel 2013 32bit PC but may need changing if you are using something else.

'https://support.microsoft.com/en-us/kb/97142
    
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal _
        uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

    Const SPIF_SENDWININICHANGE = &H2
    Const SPIF_UPDATEINIFILE = &H1

    Const SPI_GETWHEELSCROLLLINES = &H68
    Const SPI_SETWHEELSCROLLLINES = &H69
    
Sub setParm()
    Dim uAction   As Long   'system parameter to query or set
    Dim uParam    As Long   'depends on system parameter - =0 for GET/New Value for SET
    Dim lpvParam  As Long   'depends on system parameter - Cur Val for GET/ Null for SET
    Dim fuWinIni  As Long   'WIN.INI update flag
    Dim ret       As Long   'return code - 0=fail

    uParam = 1  ' Mouse Scroll Amount
    
    ret = SystemParametersInfo(SPI_SETWHEELSCROLLLINES, uParam, lpvParam, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
    
    'ret = SystemParametersInfo(SPI_GETWHEELSCROLLLINES, uParam, lpvParam, fuWinIni)
    'MsgBox "New Scroll Amount: " & lpvParam
End Sub

Regards,

 

[Jaafar Tribak]

Hi Rick,
The SystemParametersInfo API alters the system settings and affects all other Windows/Applications which is considered bad practice. According the documentation, the fuWinIni parameter can be set to 0 if you don't want to update the user profile which sounds just what we want but I couldn't make it work

An alternative to using the invasive SystemParametersInfo API, one could use PeekMessage which would only affect the excel application and leave the user's system setting untouched .. Something like the following :

Option Explicit

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
    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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
#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 WaitMessage Lib "user32" () 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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
    
Private Const WM_MOUSEWHEEL = &H20A
Private Const PM_REMOVE = &H1
Private bCancel As Boolean


Private Sub Workbook_Open()
    Dim tMSG As MSG
    Do
        WaitMessage
        If PeekMessage(tMSG, Application.hwnd, 0, 0, PM_REMOVE) Then
            Select Case tMSG.message
                Case WM_MOUSEWHEEL
                    If tMSG.wParam > 0 Then
                        ActiveWindow.SmallScroll up:=1
                    Else
                        ActiveWindow.SmallScroll down:=1
                    End If
                Case Else
                    PostMessage tMSG.hwnd, tMSG.message, tMSG.wParam, tMSG.lParam
            End Select
        End If
        DoEvents
    Loop Until bCancel
End Sub


Private Sub Workbook_BeforeClose(Cancel As Boolean)
    bCancel = True
End Sub

 

[RickXL]

Thanks Jaafar.

I knew it would be possible to intercept the Windows Messages but I have never done that with VBA and didn't know where to start. I knew someone who would be able to do that, though.

The only downside I noticed is that you need to stop the Workbook_Open macro if you need to do any macro coding then remember to re-start it afterwards. However, it does make the change in settings apply only to the opened Workbook and not everything in Windows which is a huge plus.

Many thanks for your input.

Regards,

 

[Jaafar Tribak]

The only downside I noticed is that you need to stop the Workbook_Open macro if you need to do any macro coding then remember to re-start it afterwards.

You can still execute any existing macros and/or event codes while the PeekMessage loop is running

 

[RickXL]

You can still execute any existing macros and/or event codes while the PeekMessage loop is running

Quite right. You just can't write or change them.

... change in settings apply only to the opened Workbook ...

I was not quite right there. The changes apply to the Application which may be many Workbooks. Also, I notice, that opening a new Application can cause the macro to stop but I can't see that being an issue for most people.

Regards,

 

[Jaafar Tribak]

I was not quite right there. The changes apply to the Application which may be many Workbooks

This update should restrict the code to the calling workbook only :

Option Explicit

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
    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 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 XlDeskHwnd As LongPtr
    Private WbkHwnd 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 WaitMessage Lib "user32" () 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 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 XlDeskHwnd As Long
    Private WbkHwnd As Long
#End If
    
Private Const WM_MOUSEWHEEL = &H20A
Private Const PM_REMOVE = &H1
Private bCancel As Boolean


Private Sub Workbook_Open()
    Dim tMSG As MSG
    Dim bIsCompatibilityMode As Boolean
    Dim sExcel8CompatibilityModeCaption As String
    
    If Val(Application.Version) >= 12 Then ' >= 2007
        bIsCompatibilityMode = CallByName(Me, "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", Me.Name & sExcel8CompatibilityModeCaption)
    If WbkHwnd = 0 Then WbkHwnd = FindWindowEx(XlDeskHwnd, 0, "EXCEL7", Me.Name & " " & sExcel8CompatibilityModeCaption)
    If WbkHwnd Then
        Do
            WaitMessage
            If PeekMessage(tMSG, WbkHwnd, 0, 0, PM_REMOVE) Then
                Select Case tMSG.message
                    Case WM_MOUSEWHEEL
                        If tMSG.wParam > 0 Then
                            ActiveWindow.SmallScroll up:=1
                        Else
                            ActiveWindow.SmallScroll down:=1
                        End If
                    Case Else
                        PostMessage tMSG.hwnd, tMSG.message, tMSG.wParam, tMSG.lParam
                End Select
            End If
            DoEvents
        Loop Until bCancel
    End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    bCancel = True
End Sub

 

[RickXL]

Good job, Jaafar.

I wonder if Microsoft know how difficult things are just because they did not include a ThisWorkbook.hwnd?


Regards,