Excel Spin Button Continues to Scroll While Mouse is on Top

Erik, funny you should say that as I was actually about to work on a similar code for a work collegue.

Bruno.

Here is something that you can try . It basically changes Up & Down the value of a Cell (Cell B2 in this case . but you can change it) as you scroll the mouse-wheel. I guess this is what you are after.

Now, at the risk of sounding repetitive, I must warn anyone trying this code or the download WB that there is always a risk of crashing the application and maybe loosing data when using external functions so please save your work first !!! .You have been warned

Here is a workbook download : http://www.savefile.com/files/2707418

Code:

Place in a standard Module and run the Test routine .

Code:

                  Option Explicit  Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long  Declare Function GetForegroundWindow Lib "user32" () As Long  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  Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long  Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long  Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long  Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _ ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long  Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long  Type POINTAPI   X As Long   Y As Long End Type  Type MSLLHOOKSTRUCT 'Will Hold the lParam struct Data     pt As POINTAPI     mouseData As Long ' Holds Forward\Bacward flag     flags As Long     time As Long     dwExtraInfo As Long End Type  Const HC_ACTION = 0 Const WH_MOUSE_LL = 14 Const WM_MOUSEWHEEL = &H20A Const GWL_WNDPROC  As Long = (-4) Const WM_ACTIVATEAPP   As Long = &H1C Const WM_ACTIVATE As Long = &H6 Const WA_ACTIVE As Long = 1 Const WA_CLICKACTIVE = 2 Const GWL_HINSTANCE = (-6)  Public gObjRange As Range Public gdblIncrementVal As Double Dim lngXLhwnd As Long Dim lngAppInstance As Long Dim lngPrcssID As Long Dim blnIsXLSubClassed As Boolean Dim blnIsMouseHooked As Boolean Dim hhkLowLevelMouse As Long Dim OldWindowProc As Long    Public Sub MouseWheelAnchor(objRange As Range, dblIncrementVal As Double)      'make sure we don't hook the mouse more than once !     If Not blnIsMouseHooked Then         hhkLowLevelMouse = SetWindowsHookEx _         (WH_MOUSE_LL, AddressOf LowLevelMouseProc, lngAppInstance, 0)                  'set flag         blnIsMouseHooked = True         'assign paramters to global variables         Set gObjRange = objRange         gdblIncrementVal = dblIncrementVal     End If  End Sub   Public Sub UnHookMouse()   If blnIsMouseHooked Then UnhookWindowsHookEx hhkLowLevelMouse blnIsMouseHooked = False   End Sub   Function LowLevelMouseProc _ (ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MSLLHOOKSTRUCT) As Long      'I noticed that if scrolling the mouse-wheel very fast an error can occur     'we can just safely skip that error     On Error Resume Next          'Unhook & get out in case the application is deactivated     If GetForegroundWindow <> lngXLhwnd Then         UnHookMouse         Exit Function     End If          If (nCode = HC_ACTION) Then         'detect when the mouse-wheel is scrolled         If wParam = WM_MOUSEWHEEL Then                          'check if rolling forward             If lParam.mouseData > 0 Then                              'if so prevent default sheet scrolling & increment value                 LowLevelMouseProc = True                 gObjRange = gObjRange + gdblIncrementVal                              'if backward prevent default sheet scrolling & decrease value             Else                 LowLevelMouseProc = True                 gObjRange = gObjRange - gdblIncrementVal             End If             Exit Function         End If     End If     LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)  End Function   Function NewWindowProc(ByVal hwnd As Long, ByVal Msg _     As Long, ByVal wParam As Long, ByVal lParam As Long) As _     Long      Dim blnXLActivated As Boolean          'trap the activation of XL     If Msg = WM_ACTIVATEAPP Then         blnXLActivated = wParam                  'if XL is has just been activated hook the mouse         If blnXLActivated = True And ActiveSheet Is gObjRange.Parent Then             MouseWheelAnchor gObjRange, gdblIncrementVal         End If         Exit Function     End If          'this is for when a Dlg or form within excel gets the focus     If Msg = WM_ACTIVATE Then              'tested and it seems that the main app window looses the         'mouse hook when it gives the focus to any of its child         'windows (Dlgs,forms)....so let's restore it now         If GetloWord(wParam) = WA_ACTIVE Or GetloWord(wParam) = WA_CLICKACTIVE Then             MouseWheelAnchor gObjRange, gdblIncrementVal         End If         Exit Function     End If     NewWindowProc = CallWindowProc(OldWindowProc, hwnd, Msg, wParam, lParam)  End Function   Sub SubClassXL(hwnd)              'Subclass The Excel Application Window     OldWindowProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewWindowProc)     If OldWindowProc Then         'set the flag for later use         blnIsXLSubClassed = True     End If      End Sub   Sub RemoveHook()      If blnIsXLSubClassed Then              'first UnSubclass xl as we don't need it anymore         SetWindowLong lngXLhwnd, GWL_WNDPROC, OldWindowProc     End If          'reset flag     blnIsXLSubClassed = False          'unhook mouse     Call UnHookMouse     If Not ActiveSheet Is gObjRange.Parent Then gObjRange.ClearContents      End Sub   Sub Apply_WheelScroll_ToRange(objRangeAnchor As Range, Optional dblIncrementVal As Double = 1)      'get app hwnd     lngXLhwnd = FindWindow("XLMAIN", Application.Caption)          'get app instance     lngAppInstance = GetWindowLong(lngXLhwnd, GWL_HINSTANCE)          'subclass XL to ensure no other App has the WheelScroll hooked     If Not blnIsXLSubClassed Then         SubClassXL lngXLhwnd     End If          If Not blnIsMouseHooked Then         MouseWheelAnchor objRangeAnchor, dblIncrementVal     End If  End Sub   Function GetloWord(ByRef value As Long) As Long      'supporting function to return the (wParam) value     GetloWord = (value And &HFFFF)  End Function   'Run this procedure and wacth the values in cell B2 Sub Test()      'change the value of the function as required     Apply_WheelScroll_ToRange objRangeAnchor:=Sheet1.Range("B2"), dblIncrementVal:=1  End Sub                

Place this in the worksheet Module :

Code:

                  Option Explicit  Private Sub Worksheet_Activate()      'restore hook      MouseWheelAnchor gObjRange, gdblIncrementVal   End Sub  Private Sub Worksheet_Deactivate()      'we need to restore the default mouse-scroll behaviour     'for the rest of the worksheets.     UnHookMouse      End Sub                

Now, one problem I have noticed is that you can't use the minimise\maximise\close buttons in the XL main window.however, you can freely move around worksheets and other applications - If you can live with that then you shoul be ok.

Tested in XL 2002 on XP only !!

Regards.

strotherafterid00.blogspot.com

Source: https://www.mrexcel.com/board/threads/use-the-scroll-wheel-to-simulate-a-spinbutton.204089/

Share this post