Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,779
- Office Version
- 2016
- Platform
- Windows
Hi dear forum,
In the past few months, I have posted various codes which show how to run code upon wheelmouse-scrolling.
Basically, intercepting the mouse scroll event relies on four known techniques : Subclassing, Installing a windows Mouse Hook, using the SetWinEventHook API or using the PeekMessage\GetMessage API functions.
Unfortunately, each of these methods carry their own set of issues. Namely the following isues:
1- Subclassing a window within excel is prone to crashing and only works when applied to modal userforms.
2- Installing a Mouse hook or using the SetWinEventHook API is a better alternative but, it puts a noticeable burden on excel and most importantly, it will crash the entire application (GPF) if an unhandled error occurs or if the VBE is reset before uninstalling the mouse hook.
3- PeekMessage\GetMessage is probably the safest method as it won't crash excel but, it requires continiously running a loop in the background. Obviously, this makes this method less than ideal and should probably only be used in small temporary loops during code execution.
The above mentioned issues could be avoided if the code was running from within a dll loaded into excel but, I am looking at making this work purely with straight VBA without any dependencies.
Here, I present a workaround which seems to work just fine after running various tests (XL 2007,2010,2016 32bit and 64bit).
Basically, I am installing a low level windows mouse hook but, from a second hidden excel instance created on the fly.
By running the mouse hook from a remote process, there will be no risk of crashing excel should an error occur while the hook is installed... There are no heavy loops continiously running in the background either.
The hidden excel instance communicates with the current excel session back and forth and closes itself automatically when the current excel session is closed.
I have made the code into an addin so it can be flexibly used from all open workbooks .
WheelScroll.xla
MouseWheel Event Handler singnature:
WheelDirection >0 Wheel Forward
WheelDirection <0 Wheel Backward
Ctrl =0 Ctrl Key is up while mousescrolling
Ctrl =-1 Ctrl Key is down while mousescrolling
Shift =0 Shift Key is up while mousescrolling
Shift =-1 Shift Key is down while mousescrolling
Cancel =TRUE to cancel mousescrolling
Note: The above event handler must be placed in the ThisWorkbook Module of the client workbook(s) (See next post in this thread for some usage examples)
Addin Code
1- Code in a Standard Module of the Addin:
2- Code in the ThisWorkbook Module of the Addin:
In the next post, I'll show some interesting uses of the addin.
In the past few months, I have posted various codes which show how to run code upon wheelmouse-scrolling.
Basically, intercepting the mouse scroll event relies on four known techniques : Subclassing, Installing a windows Mouse Hook, using the SetWinEventHook API or using the PeekMessage\GetMessage API functions.
Unfortunately, each of these methods carry their own set of issues. Namely the following isues:
1- Subclassing a window within excel is prone to crashing and only works when applied to modal userforms.
2- Installing a Mouse hook or using the SetWinEventHook API is a better alternative but, it puts a noticeable burden on excel and most importantly, it will crash the entire application (GPF) if an unhandled error occurs or if the VBE is reset before uninstalling the mouse hook.
3- PeekMessage\GetMessage is probably the safest method as it won't crash excel but, it requires continiously running a loop in the background. Obviously, this makes this method less than ideal and should probably only be used in small temporary loops during code execution.
The above mentioned issues could be avoided if the code was running from within a dll loaded into excel but, I am looking at making this work purely with straight VBA without any dependencies.
Here, I present a workaround which seems to work just fine after running various tests (XL 2007,2010,2016 32bit and 64bit).
Basically, I am installing a low level windows mouse hook but, from a second hidden excel instance created on the fly.
By running the mouse hook from a remote process, there will be no risk of crashing excel should an error occur while the hook is installed... There are no heavy loops continiously running in the background either.
The hidden excel instance communicates with the current excel session back and forth and closes itself automatically when the current excel session is closed.
I have made the code into an addin so it can be flexibly used from all open workbooks .
WheelScroll.xla
MouseWheel Event Handler singnature:
VBA Code:
Private Sub OnMouseWheelScroll( _
ByVal WheelDirection As Long, _
ByVal Ctrl As Integer, _
ByVal Shift As Integer, _
ByRef Cancel As Boolean)WheelDirection >0 Wheel Forward
WheelDirection <0 Wheel Backward
Ctrl =0 Ctrl Key is up while mousescrolling
Ctrl =-1 Ctrl Key is down while mousescrolling
Shift =0 Shift Key is up while mousescrolling
Shift =-1 Shift Key is down while mousescrolling
Cancel =TRUE to cancel mousescrolling
Note: The above event handler must be placed in the ThisWorkbook Module of the client workbook(s) (See next post in this thread for some usage examples)
Addin Code
1- Code in a Standard Module of the Addin:
VBA Code:
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MOUSEHOOKSTRUCT
Location As POINTAPI
MouseData As Long
Flags As Long
time As Long
ExtraInfo As Long
End Type
#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 Declare PtrSafe Function CLSIDFromString Lib "Ole32" (ByVal lpsz As LongPtr, pclsid As Any) As Long
Private Declare PtrSafe Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As LongPtr, ppunk As Any) As Long
Private Declare PtrSafe Function RegisterActiveObject Lib "OleAut32" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
Private Declare PtrSafe Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) 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
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As LongPtr)
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As Long) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
Private lMouseHook As LongPtr
#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 Declare Function CLSIDFromString Lib "Ole32" (ByVal lpsz As Long, pclsid As Any) As Long
Private Declare Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As Long, ppunk As Any) As Long
Private Declare Function RegisterActiveObject Lib "OleAut32" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
Private Declare Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) 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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private lMouseHook As Long
#End If
Private bHookIsSet As Boolean
Private bCancelArgument As Boolean
Private lErr As Long
Private oAddin As Workbook
Private oActiveWb As Object
Private lWheelDirection As Long
Private iCtrlKey As Integer
Private iShiftKey As Integer
Public Sub StartMouseWheelHook()
Dim ClassID(0 To 3) As Long
Dim lOleId As Long
Dim lRet As Long
Dim oApp As Application
On Error GoTo Xit
If ThisWorkbook.ReadOnly Then Exit Sub
If CBool(GetProp(GetDesktopWindow, "OleId")) Then Exit Sub
Call SetProp(GetDesktopWindow, "PID", GetCurrentProcessId)
lRet = CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
lRet = RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId)
If lRet = 0& Then
Call SetProp(GetDesktopWindow, "OleId", lOleId)
Set oApp = New Application
With oApp
.Workbooks.Open Filename:=ThisWorkbook.FullName, UpdateLinks:=False, ReadOnly:=True
.Run "On_Open"
End With
End If
Exit Sub
Xit:
oApp.Quit
Call ResetProps
Call FinishMouseWheelHook
End Sub
Public Sub FinishMouseWheelHook()
Dim pUnk As IUnknown
Dim Wb As Workbook
Dim ClassID(0 To 3) As Long
Dim lRet As Long
On Error GoTo Xit
If ThisWorkbook.ReadOnly Then Exit Sub
lRet = CoDisconnectObject(ThisWorkbook, 0)
lRet = RevokeActiveObject(CLng(GetProp(GetDesktopWindow, "OleId")), 0)
lRet = CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35268}"), ClassID(0))
lRet = GetActiveObject(ClassID(0), 0, pUnk)
If lRet = 0& Then
Set Wb = pUnk
Set pUnk = Nothing
If Not Wb Is Nothing Then
Wb.Parent.Run "On_Close"
Set Wb = Nothing
End If
Call RemoveProp(GetDesktopWindow, "OleId")
End If
Exit Sub
Xit:
Call ResetProps
End Sub
Public Sub Register(ByVal Wb As Workbook)
Dim ClassID(0 To 3) As Long
Dim lOleId As Long
Dim lRet As Long
If Wb.IsAddin = False Then
lRet = RevokeActiveObject(CLng(GetProp(GetDesktopWindow, "CurrentWorkbook")), 0)
lRet = CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35271}"), ClassID(0))
lRet = RegisterActiveObject(Wb, ClassID(0), 0, lOleId)
If lRet = 0& Then
Call SetProp(GetDesktopWindow, "CurrentWorkbook", lOleId)
End If
End If
End Sub
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
' All of the following routines are executed ONLY in the second excel instance !!!
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Private Sub On_Open()
Dim ClassID(0 To 3) As Long
Dim lOleId As Long
Dim lRet As Long
If ThisWorkbook.ReadOnly Then
Set oAddin = GetAddin
If oAddin Is Nothing Then
ThisWorkbook.Saved = True: Application.Quit
Else
lRet = CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35268}"), ClassID(0))
lRet = RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId)
If lRet = 0& Then
Call SetTimer(Application.hwnd, 0, 0, AddressOf CallSetHook)
End If
End If
End If
End Sub
Private Sub On_Close()
Call UnInstallMouseHook
Call KillTimer(Application.hwnd, 0)
Call ResetProps
Set oAddin = Nothing
ThisWorkbook.Saved = True
DoEvents
Application.OnTime Now, "CloseRemoteXL"
End Sub
Private Sub ResetProps()
Call RemoveProp(GetDesktopWindow, "OleId")
Call RemoveProp(GetDesktopWindow, "PID")
Call RemoveProp(GetDesktopWindow, "CurrentWorkbook")
End Sub
Private Sub CloseRemoteXL()
Application.Quit
End Sub
Private Sub CallSetHook()
If Not bHookIsSet Then
InstallMouseHook
End If
Call KillTimer(Application.hwnd, 0)
End Sub
Private Sub InstallMouseHook()
Const WH_MOUSE_LL As Long = 14
If Not bHookIsSet Then
lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, GetModuleHandle(vbNullString), 0&)
bHookIsSet = lMouseHook <> 0
End If
End Sub
Private Sub UnInstallMouseHook()
If bHookIsSet Then
Call UnhookWindowsHookEx(lMouseHook)
bHookIsSet = lMouseHook = 0
End If
End Sub
#If Win64 Then
Private Function MouseProc(ByVal ncode As Long, ByVal wParam As LongLong, ByRef lParam As MOUSEHOOKSTRUCT) As LongLong
#Else
Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long
#End If
Const HC_ACTION As Long = 0&
Const WM_MOUSEWHEEL = &H20A
Const VK_SHIFT = &H10
Const VK_CONTROL = &H11
Dim sBuff As String * 256, lRet As Long
Dim lProcessId As Long
On Error Resume Next
If GetAddin Is Nothing Then
Call On_Close
Exit Function
End If
If ncode < HC_ACTION Then
MouseProc = CallNextHookEx(lMouseHook, ncode, wParam, lParam)
Exit Function
End If
lRet = GetClassName(GetForegroundWindow, sBuff, 256)
If Left(sBuff, lRet) = "wndclass_desked_gsk" Then Exit Function
Call GetWindowThreadProcessId(GetForegroundWindow, lProcessId)
If GetProp(GetDesktopWindow, "PID") <> lProcessId Then Exit Function
iCtrlKey = 0: iShiftKey = 0
If wParam = WM_MOUSEWHEEL Then
If GetKeyState(VK_CONTROL) And &H80 Then
iCtrlKey = -1
End If
If GetKeyState(VK_SHIFT) And &H80 Then
iShiftKey = -1
End If
lWheelDirection = Hiword(CLng(lParam.MouseData))
Call KillTimer(Application.hwnd, 0)
Call SetTimer(Application.hwnd, 0, 0&, AddressOf CallOnScroll)
MouseProc = -1
Exit Function
End If
MouseProc = CallNextHookEx(lMouseHook, ncode, wParam, ByVal lParam)
End Function
Private Sub CallOnScroll()
Call KillTimer(Application.hwnd, 0)
On Error Resume Next
Set oActiveWb = GetActiveWorkBook
With oActiveWb.Application
bCancelArgument = False
lErr = 0
Call .Run(oActiveWb.CodeName & ".OnMouseWheelScroll", lWheelDirection, iCtrlKey, iShiftKey, bCancelArgument)
lErr = Err.Number
Call Sleep(50)
Call SetTimer(Application.hwnd, 0, 0&, AddressOf DoWheelScroll)
End With
End Sub
Private Sub DoWheelScroll()
Const MOUSEEVENTF_WHEEL = &H800
Const WHEEL_DELTA = 120
Call KillTimer(Application.hwnd, 0)
On Error Resume Next
Call UnInstallMouseHook
With oActiveWb.Application
If .hwnd = GetForegroundWindow Then
If bCancelArgument = False Or lErr Then
lErr = 0
Call mouse_event(MOUSEEVENTF_WHEEL, 0&, 0&, lWheelDirection, 0)
End If
End If
End With
Call InstallMouseHook
End Sub
Private Function GetAddin() As Workbook
Dim pUnk As IUnknown
Dim ClassID(0 To 3) As Long
Dim lRet As Long
lRet = CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
lRet = GetActiveObject(ClassID(0), 0, pUnk)
If lRet = 0& Then Set GetAddin = pUnk
End Function
Private Function GetActiveWorkBook() As Object
Dim pUnk As IUnknown
Dim ClassID(0 To 3) As Long
Dim lRet As Long
On Error Resume Next
lRet = CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35271}"), ClassID(0))
lRet = GetActiveObject(ClassID(0), 0, pUnk)
If lRet = 0& Then Set GetActiveWorkBook = pUnk
End Function
Private Function Hiword(ByVal DWord As Long) As Integer
Hiword = (DWord And &HFFFF0000) \ &H10000
End Function2- Code in the ThisWorkbook Module of the Addin:
VBA Code:
Option Explicit
Private WithEvents XlApp As Application
Private Sub Workbook_Open()
Set XlApp = Application
Call StartMouseWheelHook
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call FinishMouseWheelHook
End Sub
Private Sub Workbook_AddinInstall()
Call Register(ActiveWorkbook)
End Sub
Private Sub XlApp_NewWorkbook(ByVal Wb As Workbook)
Call Register(Wb)
End Sub
Private Sub XlApp_WorkbookActivate(ByVal Wb As Workbook)
Call Register(Wb)
End SubIn the next post, I'll show some interesting uses of the addin.
