Run macro when sheet is scrolled left of right using the excel scrollbar (Not scrollbar Control)

[jonnn21]

I have a macro I want to run whenever the horizonal scroll bar is moved. I am talking about the standard built in Scrollbar in Excel not an activeX control

Is this possible?

 

[Jaafar Tribak]

Excel doesn't provide an event handler for scrolling worksheets.

However, I have come up with this workaround as follows :

Workbook Demo:
WorksheetScrollEvent.xlsm

The SheetScroll event handler passes various handy arguments such as scroll type (Vert vs Horiz), scroll direction (Up\Down & Left\Right), current sheet name, number of rows & columns scrolled and finally an Undo boolean argument if you want to cancel the scroll operation.

This is just a hacky workaround. Unlike if we were to use a high resolution windows timer, this workaround is not too fast but it is fast enough and much safer.

1- Add a Class Module to your project, give the Class Module the name of CScrollEvent and place the following code in it :

Option Explicit

Public Event SheetScroll( _
    ByVal Sh As Worksheet, _
    ByVal ScrollType As Long, _
    ByVal ScrollDirection As Long, _
    ByVal ScrolledRowsCount As Long, _
    ByVal ScrolledColumnsCount As Long, _
    ByRef UndoScroll As Boolean _
)

Private WithEvents MonitorSheetScroll As CommandBars
Private WithEvents Wb As Workbook

#If VBA7 Then
    Private Declare PtrSafe Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare PtrSafe Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lpMutexAttributes As Any, ByVal bInitialOwner As Long, ByVal lpName As String) As LongPtr
    Private Declare PtrSafe Function ReleaseMutex Lib "kernel32" (ByVal hMutex As LongPtr) As Long
    Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) 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
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lpMutexAttributes As Any, ByVal bInitialOwner As Long, ByVal lpName As String) As LongPtr
    Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As LongPtr) As Long
    Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
#End If

Private lPrevRow As Long, lPrevCol As Long

Private Sub Class_Initialize()
    Call PreventMultipleClassInstances
    Set Wb = ThisWorkbook
    Set MonitorSheetScroll = Application.CommandBars
    Call MonitorSheetScroll_OnUpdate
End Sub

Private Sub Class_Terminate()
    Call ReleasePreviousMutex
    PreventSleepMode = False
    Set Wb = Nothing
    Set MonitorSheetScroll = Nothing
End Sub

Private Sub MonitorSheetScroll_OnUpdate()

    Dim bool1 As Byte, bool2 As Byte, bool3 As Byte, bool4 As Byte, bool5 As Byte, bool6 As Byte
    Dim lScrollType As Long, lScrollDirection As Long
    Dim bUndo As Boolean
 
    If Not ActiveWorkbook Is ThisWorkbook Then GoTo Xit
 
    With Application.ActiveWindow.VisibleRange
        bool1 = CBool(lPrevRow <> .Row And lPrevRow)
        bool2 = CBool(lPrevCol <> .Column And lPrevCol)
        bool3 = CBool(lPrevRow < .Row And lPrevRow)
        bool4 = CBool(lPrevRow > .Row And lPrevRow)
        bool5 = CBool(lPrevCol < .Column And lPrevCol)
        bool6 = CBool(lPrevCol > .Column And lPrevCol)
        lScrollType = (bool1 And 1&) + (bool2 And 2&)
        lScrollDirection = (bool3 And 1&) + (bool4 And 2&) + (bool5 And 3&) + (bool6 And 4&)
        If lScrollType Then
            RaiseEvent SheetScroll(ActiveSheet, lScrollType, lScrollDirection, .Row - lPrevRow, .Column - lPrevCol, bUndo)
            If bUndo Then
                Set MonitorSheetScroll = Nothing
                With Application.ActiveWindow
                    .ScrollRow = lPrevRow
                    .ScrollColumn = lPrevCol
                End With
                Set MonitorSheetScroll = Application.CommandBars
                Exit Sub
            End If
        End If
        lPrevRow = .Row
        lPrevCol = .Column
    End With
 
Xit:
    PreventSleepMode = True
    With Application.CommandBars.FindControl(Id:=2040&)
        .Enabled = Not .Enabled
    End With

End Sub

Private Sub PreventMultipleClassInstances()

    Const ERROR_ALREADY_EXISTS = &HB7
    Dim hMutex As LongPtr
    '
    hMutex = CreateMutex(ByVal 0&, 1&, "Mutex")
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
        Call ReleaseMutex(hMutex)
        Call CloseHandle(hMutex)
        Call ReleasePreviousMutex
        MsgBox "No more than one *CScrollEvent* Class instance is allowed." & _
               vbNewLine & vbNewLine & "Please, try again.", vbExclamation
        End
    Else
        Call SetProp(Application.hwnd, "Mutex", hMutex)
    End If
 
End Sub

Private Sub ReleasePreviousMutex()
    Dim lPrevMutex As LongPtr
    lPrevMutex = GetProp(Application.hwnd, "Mutex")
    Call ReleaseMutex(lPrevMutex)
    Call CloseHandle(lPrevMutex)
End Sub

Private Property Let PreventSleepMode(ByVal bPrevent As Boolean)
    Const ES_SYSTEM_REQUIRED As Long = &H1
    Const ES_DISPLAY_REQUIRED As Long = &H2
    Const ES_AWAYMODE_REQUIRED = &H40
    Const ES_CONTINUOUS As Long = &H80000000
 
    If bPrevent Then
        Call SetThreadExecutionState(ES_CONTINUOUS Or ES_DISPLAY_REQUIRED Or ES_SYSTEM_REQUIRED Or ES_AWAYMODE_REQUIRED)
    Else
        Call SetThreadExecutionState(ES_CONTINUOUS)
    End If
End Property

Private Sub wb_SheetDeactivate(ByVal Sh As Object)
     lPrevRow = 0&
     lPrevCol = 0&
End Sub

2- Class Usage In the ThisWorkbook Module

Option Explicit

Private WithEvents Wb As CScrollEvent

Private Sub Workbook_Open()
    Set Wb = New CScrollEvent
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set Wb = Nothing
End Sub

'___________________________________________ Scroll Event Handler ________________________________________________

'| =========================|
'| EVENT ARGUMENTS VALUES : |
'| =========================|

    ' ScrollType Argument:
    ' --------------------
        ' Vertical = 1&
        ' Horizontal = 2&
        ' Both Vertical AND Horizontal = 3&
 
    ' ScrollDirection Argument:
    ' -------------------------
        ' Down = 1&
        ' Up = 2&
        ' Right = 3&
        ' Left = 4&
        ' Both Left AND Up = 6&

Private Sub Wb_SheetScroll( _
    ByVal Sh As Worksheet, _
    ByVal ScrollType As Long, _
    ByVal ScrollDirection As Long, _
    ByVal ScrolledRowsCount As Long, _
    ByVal ScrolledColumnsCount As Long, _
    ByRef UndoScroll As Boolean _
)

    Dim sScrollType As String, sScrollDirection As String

    Select Case ScrollType
        Case 1&
            sScrollType = "Vertical scroll."
        Case 2&
            sScrollType = "Horizontal scroll."
        Case 3&
            sScrollType = "Both (Vertical AND Horizontal) scroll."
    End Select

    Select Case ScrollDirection
        Case 1&
            sScrollDirection = "Down direction."
        Case 2&
            sScrollDirection = "Up direction."
        Case 3&
            sScrollDirection = "Right direction."
        Case 4&
            sScrollDirection = "Left direction."
        Case 6&
            sScrollDirection = "(Left AND Up) direction."
    End Select
 
    'UndoScroll = True '<=== Set arg to TRUE to undo the scrolling.

    MsgBox "* Current Sheet : " & vbTab & Sh.Name & "." & vbNewLine & vbNewLine & _
           "* Scroll Type : " & vbTab & sScrollType & vbNewLine & vbNewLine & _
           "* Scroll Direction : " & vbTab & sScrollDirection & vbNewLine & vbNewLine & _
           "* Scrolled Rows Count : " & vbTab & ScrolledRowsCount & vbNewLine & vbNewLine & _
           "* Scrolled Columns Count : " & vbTab & ScrolledColumnsCount & vbNewLine & vbNewLine & _
           "* Undo Scroll : " & vbTab & UndoScroll, , "Worksheet Scroll Event."


'    Debug.Print "Current Sheet: "; Sh.Name & vbNewLine & vbNewLine & _
'                "Scroll Type: "; sScrollType & vbNewLine & vbNewLine & _
'                "Scroll Direction: "; sScrollDirection & vbNewLine & vbNewLine & _
'                "Scrolled Rows Count : "; ScrolledRowsCount & vbNewLine & vbNewLine & _
'                "Scrolled Columns Count : "; ScrolledColumnsCount & vbNewLine & vbNewLine & _
'                "Undo Scroll : "; UndoScroll
'    Debug.Print "=========================================="

End Sub

The above scroll event implementation is a generic one... In your particular scenario where you just want to run a macro when scrolling horizontally, you should use a simplified version of the code in the event handler as follows :

Again, in the ThisWorkbook Module :

Private Sub Wb_SheetScroll( _
    ByVal Sh As Worksheet, _
    ByVal ScrollType As Long, _
    ByVal ScrollDirection As Long, _
    ByVal ScrolledRowsCount As Long, _
    ByVal ScrolledColumnsCount As Long, _
    ByRef UndoScroll As Boolean _
)
 
    If ScrollType = 2& Then
        MsgBox "You scrolled sheet [" & Sh.Name & _
               "] horizontally " & IIf(ScrollDirection = 3&, "to the right.", "to the left.") & _
               " by " & ScrolledColumnsCount & " Column(s)."
    End If
 
End Sub

Note that this SheetScroll event works at the workbook level for all sheet tabs... If you just want this to apply to only specific sheet(s), make use of the Sh argument to restrict the sheet(s) you want the event to apply to.

 

[jonnn21]

You are a GODSEND!!!!

I copied my macro over, then called it in place of the message box and it WORKS!!

I have been at this for a week and this solution is #1

 

[Jaafar Tribak]

You are a GODSEND!!!!

I copied my macro over, then called it in place of the message box and it WORKS!!

I have been at this for a week and this solution is #1

Glad you got this working and thanks for the feedback.