Nifty Class for Trapping Mouse Clicks on Cells

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,779
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

There are times when excel users need to detect when a cell is being mouse-clicked ... The worksheet Selection_Change event is often used for this purpose but it has two main problems :
A- it doesn't differenciate between keyboard and mouse selections
B- It doesn't work if the same cell is repeatedly clicked without first having activated another cell

The following small Class (C_CellClickEvent) uses the CommandBars _OnUpdate event in combination with a few API calls to overcome the issues mentioned above ... Once the Class is instantiated, the custom and easy-to-use Wb_CellClick(ByVal Target As Range) event handler located in the workbook module becomes available

Workbook Download demo

1- Here is the Class code : (Class name = C_CellClickEvent)
Code:
Option Explicit

Private WithEvents CmBrasEvents As CommandBars
Private WithEvents wbEvents As Workbook
Event CellClick(ByVal Target As Range)


Private Type POINTAPI
    x As Long
    Y As Long
End Type


Private Type KeyboardBytes
     kbByte(0 To 255) As Byte
End Type


#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
#End If


Private kbArray As KeyboardBytes
Private oPrevSelection As Range


Private Sub Class_Initialize()
    Set CmBrasEvents = Application.CommandBars
    Set wbEvents = ThisWorkbook
    GetKeyboardState kbArray
    kbArray.kbByte(vbKeyLButton) = 1
    SetKeyboardState kbArray
End Sub


Private Sub Class_Terminate()
    Set CmBrasEvents = Nothing
    Set wbEvents = Nothing
End Sub


Private Sub CmBrasEvents_OnUpdate()
    Dim tpt As POINTAPI
    
    On Error Resume Next
    GetKeyboardState kbArray
    If GetActiveWindow <> Application.hwnd Then Exit Sub
    GetCursorPos tpt
    If GetKeyState(vbKeyLButton) = 1 Then
        If TypeName(ActiveWindow.RangeFromPoint(tpt.x, tpt.Y)) = "Range" Then
            If oPrevSelection.Address = ActiveWindow.RangeFromPoint(tpt.x, tpt.Y).Address Then
                RaiseEvent CellClick(Selection)
            End If
        End If
    End If
    kbArray.kbByte(vbKeyLButton) = 0
    SetKeyboardState kbArray
End Sub


Private Sub wbEvents_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    Set oPrevSelection = Target
End Sub


2- And here is an example of how to implement the Class : ( Code to be placed in the ThisWorkbook module)
Code:
Option Explicit


Private WithEvents Wb As C_CellClickEvent


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


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


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Wb Is Nothing Then
        Set Wb = New C_CellClickEvent
    End If
End Sub


[B][COLOR=#008000]' Here is the Cell Click event handler[/COLOR][/B]
Private Sub Wb_CellClick(ByVal Target As Range)
    With Target
        .Font.Bold = True
        .Font.Name = IIf(.Value = "", "Wingdings", "calibri")
        .Value = IIf(.Value = "", "ü", "")
        MsgBox "You clicked cell : " & vbLf & .Address(External:=True), vbInformation
    End With
End Sub

Code Written and tested in Excel 2010 Win 10 (64bit)
 
Last edited:

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Hello Jaafar,

Thanks a lot for sharing your class module ...!!!

Cheers :smile:
 
Upvote 0
Thanks Jaafar

Your code works well for me in Excel2010/13 Win8(32).

I admire your dogged pursuit of the (simple!) left mouse click event over many years:

http://www.mrexcel.com/forum/excel-...se-click-event-without-using-subclassing.html (including Tom Urtis's neat left click/right click swap)
http://www.mrexcel.com/forum/excel-questions/208072-mouse-click-event.html
http://www.mrexcel.com/forum/excel-...acro-capture-mouseclick-excel-sheet-cell.html

BTW: How would you suppress the click event being raised on Workbook_Open?
 
Upvote 0
@StephenCrump

Your code works well for me in Excel2010/13 Win8(32).

I admire your dogged pursuit of the (simple!) left mouse click event over many years:

Trapping Left Mouse Click Event Without Using Subclassing. (including Tom Urtis's neat left click/right click swap)
Mouse click event
VB Macro to capture mouseclick on excel sheet cell

Thanks for the feedback and for your interest ...

BTW: How would you suppress the click event being raised on Workbook_Open?

I mistakenly set the value of vbKeyLButton to 1 in the class Initiallize event ... It should be 0 as follows :
Code:
Private Sub Class_Initialize()
    Set CmBrasEvents = Application.CommandBars
    Set wbEvents = ThisWorkbook
    GetKeyboardState kbArray
    kbArray.kbByte(vbKeyLButton) [B]= 0[/B]
    SetKeyboardState kbArray
End Sub
 
Last edited:
Upvote 0
Hi all,

Workbook example.

I am presenting here a new approach to trap the Cell Click event ... This approach works by installing a Windows Mouse Hook but from a hidden second instance of excel created on the fly at runtime.

This second excel instance automatically detects when the user has finished and has closed the workbook so it silently unloads itself from memory.

The reason I am using another excel instance is in order to avoid the potential crashing risks related to using a mouse hook in vba.

Also, In my opinion, one other good thing about this code is the fact that it shows how two excel processes acn interact and communicate with each other via code.

1- Code in a Standard Module :
Code:
Option Explicit

Private Type POINTAPI
    x As Long
    Y As Long
End Type

Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private lMouseHook As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private lMouseHook As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const WH_MOUSE_LL As Long = 14
Private Const HC_ACTION As Long = 0
Private Const WM_LBUTTONUP = &H202

Private bHookIsSet As Boolean
Private oWb As Workbook

Sub Start()
    Dim ClassID(0 To 3) As Long
    Dim lOleId As Long
    Dim oApp As Application
    
    On Error GoTo Xit
    
    If CBool(GetProp(GetDesktopWindow, "OleId")) Then Exit Sub
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
    Call RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId)
    SetProp GetDesktopWindow, "OleId", lOleId
    Set oApp = New Application
    With oApp
        .Workbooks.Open Filename:=ThisWorkbook.FullName, UpdateLinks:=False, ReadOnly:=True
        .Run "On_Open"
    End With
    Exit Sub
Xit:
    oApp.Quit
    Call Finish
End Sub

Sub Finish()
    Dim pUnk As IUnknown
    Dim Wb As Workbook
    Dim ClassID(0 To 3) As Long

    CoDisconnectObject ThisWorkbook, 0
    RevokeActiveObject CLng(GetProp(GetDesktopWindow, "OleId")), 0
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35268}"), ClassID(0))
    Call GetActiveObject(ClassID(0), 0, pUnk)
    Set Wb = pUnk
    Set pUnk = Nothing
    If Not Wb Is Nothing Then
        On Error Resume Next
        Wb.Parent.Run "On_Close"
        Set Wb = Nothing
    End If
    Call RemoveProp(GetDesktopWindow, "OleId")
End Sub


[B][COLOR=#008000]'\\**********************************************************************************[/COLOR][/B]
[B][COLOR=#008000]'\\All of the following routines are executed ONLY in the second excel instance !!![/COLOR][/B]
[B][COLOR=#008000]'\\**********************************************************************************[/COLOR][/B]
Private Sub On_Open()
    Dim ClassID(0 To 3) As Long
    Dim lOleId2 As Long

    If ThisWorkbook.ReadOnly Then
        Set oWb = GetWorkBook
        If oWb Is Nothing Then
            ThisWorkbook.Saved = True: Application.Quit
        Else
            Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35268}"), ClassID(0))
            Call RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId2)
            SetTimer Application.hwnd, 0, 0, AddressOf CallSetHook
        End If
    End If
End Sub

Private Sub On_Close()
    UnInstallMouseHook
    KillTimer Application.hwnd, 0
    RemoveProp GetDesktopWindow, "OleId"
    Set oWb = Nothing
    ThisWorkbook.Saved = True
    DoEvents
    Application.Quit
End Sub

Private Sub CallSetHook()
    If Not bHookIsSet Then
        InstallMouseHook
    End If
    KillTimer Application.hwnd, 0
End Sub

Private Sub InstallMouseHook()
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        Dim hInstance As LongPtr
        hInstance = Application.HinstancePtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Dim hInstance As Long
        hInstance = Application.hInstance
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    If Not bHookIsSet Then
        lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, hInstance, 0)
        bHookIsSet = lMouseHook <> 0
    End If
End Sub

Private Sub UnInstallMouseHook()
    If bHookIsSet Then
        UnhookWindowsHookEx lMouseHook
        lMouseHook = 0
        bHookIsSet = False
    End If
End Sub

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function MouseProc(ByVal ncode As Long, ByVal wParam As LongPtr, ByRef lparam As MOUSEHOOKSTRUCT) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, ByRef lparam As MOUSEHOOKSTRUCT) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    On Error Resume Next
    If GetWorkBook Is Nothing Then
        Call On_Close
        Exit Function
    End If

    If (ncode = HC_ACTION) Then
        If wParam = WM_LBUTTONUP Then
            Call SetTimer(Application.hwnd, 0, 0, AddressOf Call*******Event)
        End If
    End If
    MouseProc = CallNextHookEx(lMouseHook, ncode, wParam, ByVal lparam)
End Function

Private Sub Call*******Event()
    On Error Resume Next
    Static oPrevctiveCell As Range
    Dim tPt As POINTAPI
    
    KillTimer Application.hwnd, 0
    GetCursorPos tPt
    
    With oWb.Application
        If TypeName(.ActiveWindow.RangeFromPoint(tPt.x, tPt.Y)) = "Range" Then
            If Not (.ActiveWindow.RangeFromPoint(tPt.x, tPt.Y).Address <> oPrevctiveCell.Address _
            And .ActiveCell.Address = oPrevctiveCell.Address) Then
                .Run "ThisWorkbook.OnCellClick", .ActiveWindow.RangeSelection
            End If
        End If
        Set oPrevctiveCell = .ActiveCell
    End With
End Sub

Private Function GetWorkBook() As Object
    Dim pUnk As IUnknown
    Dim ClassID(0 To 3) As Long
    
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
    Call GetActiveObject(ClassID(0), 0, pUnk)
    Set GetWorkBook = pUnk
End Function

2- Code in the ThisWorkbook Module : (implements the above code)
Code:
Option Explicit

[B][COLOR=#008000]'\\===========================[/COLOR][/B]
[B][COLOR=#008000]'\\ OnCellClick Pseudo-Event:[/COLOR][/B]
[B][COLOR=#008000]'\============================[/COLOR][/B]

Private Sub OnCellClick(ByVal Target As Range)

[B][COLOR=#008000]   '\\ Toggle Tick\Cross marks on cell "A1"[/COLOR][/B]
    With Target
        If ActiveSheet Is Sheet1 Then
            If .Address = Range("a1").Address Then
                .Font.Color = vbRed
                .Font.Size = 18
                .Font.Name = "Wingdings"
                .Value = IIf(.Value <> Chr(252), Chr(252), Chr(251))
            End If
        End If
    End With

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call Finish
End Sub

Public Sub Workbook_Open()
    Call Start
End Sub
 
Upvote 0
Hello Jaafar,

Brilliantly Indispensable ... !!! :)

Should be an Excel native feature ...!!!

Avec mes remerciements les plus chaleureux ...

:pray:
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

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