Spork Schivago
New Member
- Joined
- Jun 10, 2019
- Messages
- 3
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.
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!!!!
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.
Code:
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!!!!