Nifty Class for Trapping Mouse Clicks on Cells

[Jaafar Tribak]

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)

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)

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)

 

[Jaafar Tribak]

Referring to the example in this thread, I suggest a small change in the OnCellClick procedure.
The original is:

.Value = IIf(.Text <> "TRUE", "TRUE", "FALSE")

which does not work properly in non-English versions. The problem is the use of the Range.Text property, which returns a Boolean value as text in the local language. When you click on an empty cell, in the Polish version, you get "PRAWDA" and the switch to FALSE will not work (it will always be TRUE [in Polish PRAWDA]). In addition, in the Iif function, the returned values are text, which will be implicitly converted to Boolean values in the English versions.
Therefore, I suggest changing this line of code to:

.Value = IIf(.Value <> True, True, False)

or

.Value = CBool(Not .Value)

Artik

Thank you Artik for your suggestion.

I should be more careful not to neglect the diff between the Range Value vs Text vs Value2 Properties.

 

[Artik]

For your hard work on the forum, I forgive you for minor stumbles.

Artik