Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,807
Office Version
  1. 2016
Platform
  1. 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:
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 Function


2- 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 Sub

In the next post, I'll show some interesting uses of the addin.
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Addin usage example 1:
Switches between worksheet tabs when wheelscrolling and holding the Shift key down:
VBA Code:
Option Explicit

Private Sub OnMouseWheelScroll( _
    ByVal WheelDirection As Long, _
    ByVal Ctrl As Integer, _
    ByVal Shift As Integer, _
    ByRef Cancel As Boolean)

    Dim oTempSheet As Worksheet

    If Shift = -1 Then
        Cancel = True
        If WheelDirection > 0 Then
            Set oTempSheet = ActiveSheet.Next
            If oTempSheet Is Nothing Then
                Set oTempSheet = ThisWorkbook.Sheets(1)
            End If
            oTempSheet.Activate
        Else
            Set oTempSheet = ActiveSheet.Previous
            If oTempSheet Is Nothing Then
                Set oTempSheet = ThisWorkbook.Sheets(Sheets.Count)
            End If
            oTempSheet.Activate
        End If
    End If

End Sub


Addin usage example 2:
Enables wheelmouse-scrolling on ListBox1 in Sheet1:
VBA Code:
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long


Private Sub OnMouseWheelScroll( _
    ByVal WheelDirection As Long, _
    ByVal Ctrl As Integer, _
    ByVal Shift As Integer, _
    ByRef Cancel As Boolean)

    Dim tCurPos As POINTAPI
   
    Call GetCursorPos(tCurPos)
   
    If TypeName(ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y)) = "OLEObject" Then
        If ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y).Name = "ListBox1" Then
            Cancel = True
            With Sheet1.ListBox1
                If WheelDirection > 0 Then
                    .TopIndex = .TopIndex - 1
                Else
                    .TopIndex = .TopIndex + 1
                End If
            End With
        End If
    End If

End Sub


Addin usage example 3:
Enables wheelmouse-scrolling on UserForm1:
VBA Code:
Option Explicit

Private Sub OnMouseWheelScroll( _
    ByVal WheelDirection As Long, _
    ByVal Ctrl As Integer, _
    ByVal Shift As Integer, _
    ByRef Cancel As Boolean)

    With UserForm1
        If WheelDirection > 0 Then
            .ScrollTop = .ScrollTop - 100
        Else
            .ScrollTop = .ScrollTop + 100
        End If
    End With

End Sub

All the above event handler codes must be placed in the ThisWorkbook Module of the client workbook(s)
 
Upvote 0
Hi

With Excel 365 64-bit
WheelScroll.xla

Excel freezes while loading any add-in

I remove every single add-on
When i start excel with the .xla file in vba project i don't see anything

Pc AMD Ryzen 7 3700X, 32 Gb Ram
 
Upvote 0
Hi

With Excel 365 64-bit
WheelScroll.xla

Excel freezes while loading any add-in

I remove every single add-on
When i start excel with the .xla file in vba project i don't see anything

Pc AMD Ryzen 7 3700X, 32 Gb Ram
Hi ISY
,
Sorry for not responding sooner.

Loading the addin alone won't do anything. Yo will need to have code (like the codes in post#2) in the client workbook

Below is an example of how to consume the addin mousewheel event from a client workboo:
1- Install and load the addin. (You have already done this step)
2- Open a new workbook.
3- Copy and paste the first code in post#2 in the the ThisWorkbook Module of the new workbook.
4- Now, go back to the workbook and try wheel-scrolling while holding the Shift key down. You should be able to switch between sheet tabs after each mousewheel scroll.
 
Upvote 0
Hi

Only on my new pc I can't use the code (I know perfectly well how an add works.)
On the laptop it works as expected while on the PC that I have been using for a week, both are updated to the windows 10 version

No virus present, It does not start with: Excel 365 64 bit
Pc AMD Ryzen 7 3700X, 32 Gb Ram (Windows 10 yet to be activated)
 
Upvote 0
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:
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 Function


2- 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 Sub

In the next post, I'll show some interesting uses of the addin.
Hello Jaafar

I read your approach. I have no experience with add-ins. So I have some questions.
I downloaded yout .xla file. I understood that I have to place some code into a standard module and the Thisworkbook module in that add-in excel. However if I try to insert a module it is greyed out so I cannot add a module to place the code in. Can you maybe add some more details on what I should do. Thanks.
 
Upvote 0
Hello Jaafar

I read your approach. I have no experience with add-ins. So I have some questions.
I downloaded yout .xla file. I understood that I have to place some code into a standard module and the Thisworkbook module in that add-in excel. However if I try to insert a module it is greyed out so I cannot add a module to place the code in. Can you maybe add some more details on what I should do. Thanks.
@RobK

Hi,

If you download the addin .xla file, you don't need to add the above code as it is already in the addin.

All you need to do, is to install the addin after you have downloaded it from the link I provided above.

If you are not sure how to install an addin in excel, please, do a search in this forum or in google to learn how.

Regards.
 
Upvote 0
@RobK

Hi,

If you download the addin .xla file, you don't need to add the above code as it is already in the addin.

All you need to do, is to install the addin after you have downloaded it from the link I provided above.

If you are not sure how to install an addin in excel, please, do a search in this forum or in google to learn how.

Regards.
Hello Jaafar,
I opened the .xla and did not find any module with the code. Is that correct?
Thanks for your answer installing I will find out.
Regards
 
Upvote 0
Hello Jaafar,
I opened the .xla and did not find any module with the code. Is that correct?
Thanks for your answer installing I will find out.
Regards
I installed the xla by browsing (from file menu add-in management) to the location where I stored the xla FILE. I placed the OnMouseWheelScroll() routine in my client app Thisworkbook module
I filled in my userform name (where you call it Userform1) that needs scrolling. I restarted the application, I start the form, but no scrolling of mousewheel active.
If I go to add_in management in visual basic editor and I do also not see the add in. Although in the file menu it is there and stated active.
Do I do something wrong?

Further more: when I want a scroll in both a userform amnd a combobox in a userform, how do I do that with the same OnMouseWheelScroll() call?

Thanks in advance

Rob
 
Upvote 0
I installed the xla by browsing (from file menu add-in management) to the location where I stored the xla FILE. I placed the OnMouseWheelScroll() routine in my client app Thisworkbook module
I filled in my userform name (where you call it Userform1) that needs scrolling. I restarted the application, I start the form, but no scrolling of mousewheel active.
If I go to add_in management in visual basic editor and I do also not see the add in. Although in the file menu it is there and stated active.
Do I do something wrong?

Further more: when I want a scroll in both a userform amnd a combobox in a userform, how do I do that with the same OnMouseWheelScroll() call?

Thanks in advance

Rob
Hello Jaafar

I put some breakpoints in my code and see that the OnMouseWheelScroll() is called indeed.
UserForm_Scroll is also activated at each scroll and passes ScrollTop to user forkm via RequestDy [parameter of userForm_Scroll.

I have two problems however
1. If I leave my application and start it again, I need to reload the xla again. As said I do not see it in tyhe VBA add-ins overview. Ansd I cannot get it there as everything greyed out.
2. If I have loaded the xla, and I close the form that uses the scroll, the scrol events (userform_Scroll) keep on being activated although the form is unloaded? So scroo also appears in plavces where I do not want it to be active. Do you have any explanation why that goes on?

Thanks

Rob
 
Upvote 0

Forum statistics

Threads
1,224,829
Messages
6,181,218
Members
453,024
Latest member
Wingit77

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top