Nifty Class for Trapping Mouse Clicks on Cells

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,577
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:
Here is a new update of the code in post#8 - Couple of small bugs have been fixed.

Updated workbook example



1- API code in a Standard Module:
VBA 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

#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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private lMouseHook As Long
#End If

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)
    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
    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

    Call CoDisconnectObject(ThisWorkbook, 0)
    Call 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


'\\**********************************************************************************
'\\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 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)
            Call SetTimer(Application.hwnd, 0, 0, AddressOf CallSetHook)
        End If
    End If
  
End Sub


Private Sub On_Close()

    Call UnInstallMouseHook
    Call KillTimer(Application.hwnd, 0)
    Call RemoveProp(GetDesktopWindow, "OleId")
    Set oWb = Nothing
    ThisWorkbook.Saved = True
    DoEvents
    Application.OnTime Now, "CloseRemoteXL"
  
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)
        lMouseHook = 0
        bHookIsSet = False
    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_LBUTTONUP = &H202

    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 CallOn_ClickEvent)
        End If
    End If
    MouseProc = CallNextHookEx(lMouseHook, ncode, wParam, ByVal lparam)
  
End Function


Private Sub CallOn_ClickEvent()

    Static oPrevctiveCell As Range
    Dim tPt As POINTAPI
  
    On Error Resume Next
  
    Call KillTimer(Application.hwnd, 0)
    Call 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


Private Sub CloseRemoteXL()

    Application.Quit
  
End Sub


2- Usage example in the ThisWorkbook Module:
VBA Code:
Option Explicit

Private Sub Workbook_Activate()
    Call Start
End Sub

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

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If Sh Is Sheet1 Then Cancel = True
End Sub



'\\===========================
'\\ OnCellClick Pseudo-Event:
'\============================

Private Sub OnCellClick(ByVal Target As Range)

    '\\ Toggle Tick\Cross marks on cell "A1"
    With Target
        If ActiveSheet Is Sheet1 Then
            If .Address = Range("a1").Address Then
                .HorizontalAlignment = xlCenter
                .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
 
Last edited:
Upvote 0

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Hi, @Jaafar Tribak. Thank you for your many contributions! But most of your code address user32, kernel32 and so on. After Microsoft 365 came along, all code refering to such dll's gets flagged and blocked by what I guess is Microsoft Defender. Making the file corrupted and not working. I don't know if you have answered a similar question like this, but do you have any thoughts on how to make Windows trust most of your contributions? I found one answer elsewhere where the user attatched the code to Microsoft and then they white-flagged it. But I need an administrators permission on my work domain in order to even try white-flagging the code.

Are you familiar with code like the one above being flagged and blocked? Should I try to be more specific and provide examples?
 
Upvote 0
@Jaafar Tribak
that's great ! I tested , my WIN is 10 and OFFICE is 2019
but I have a question , if make it more dynamically not specific cell I mean in all cells for column A or maybe any column contain data when select many cells in different columns should tick right or wrong
 
Upvote 0
Here is a new update of the code in post#8 - Couple of small bugs have been fixed.

Updated workbook example



Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
I know this is a really old post, but shouldn't the type be:
VBA Code:
Type MOUSEHOOKSTRUCT
        pt As POINTAPI
        hwnd As LongPtr
        wHitTestCode As Long
        dwExtraInfo As LongPtr
End Type
 
Upvote 0
I know this is a really old post, but shouldn't the type be:
VBA Code:
Type MOUSEHOOKSTRUCT
        pt As POINTAPI
        hwnd As LongPtr
        wHitTestCode As Long
        dwExtraInfo As LongPtr
End Type
Yes.

I will take a look later .

Thank you.
 
Upvote 0
I know this is a really old post, but shouldn't the type be:
VBA Code:
Type MOUSEHOOKSTRUCT
        pt As POINTAPI
        hwnd As LongPtr
        wHitTestCode As Long
        dwExtraInfo As LongPtr
End Type

The reason it worked is because the hwnd and dwExtraInfo resolve to 32bit Long values (size) even in x64 process.

I have updated the code with the propper declarations.

File demo
OnCellCilck.xls


VBA Code:
Private Type MOUSEHOOKSTRUCT
    #If Win64 Then
        pt As POINTAPI
        hwnd As LongLong
        wHitTestCode As Long
        dwExtraInfo As LongLong
     #Else
        pt As POINTAPI
        hwnd As Long
        wHitTestCode As Long
        dwExtraInfo As Long
     #End If
End Type
 
Upvote 0
Just for the record, I am posting here a recent update with a couple of improvements:
Workbook Demo


1- Code in a Standard Module (basMod)
VBA Code:
Option Explicit

Private Type POINTAPI
    x As Long
    Y As Long
End Type

Private Type MOUSEHOOKSTRUCT
    #If Win64 Then
        pt As POINTAPI
        hwnd As LongLong
        wHitTestCode As Long
        dwExtraInfo As LongLong
     #Else
         pt As POINTAPI
        hwnd As Long
        wHitTestCode As Long
        dwExtraInfo As Long
     #End If
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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private lMouseHook As Long
#End If

Private oWb As Workbook
Private bHookIsSet As Boolean
Private bEnableCellClick As Boolean


Public Property Let EnableCellClickEvent(ByVal bEnable As Boolean)

    Dim ClassID(0 To 3) As Long
    Dim lOleId As Long
    Dim oApp As Application
    Dim pUnk As IUnknown
    Dim Wb As Workbook

    If bEnable Then
        On Error GoTo Xit
        If CBool(GetProp(GetDesktopWindow, "OleId")) Then Exit Property
        Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
        Call RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId)
        Call SetProp(GetDesktopWindow, "OleId", lOleId)
        Set oApp = CreateObject("Excel.Application")
        With oApp
            .Workbooks.Open Filename:=ThisWorkbook.FullName, UpdateLinks:=False, ReadOnly:=True
            .Run "On_Open"
        End With
        bEnableCellClick = True
        Exit Property
Xit:
        oApp.Quit
        Call Finish
    Else
        Call CoDisconnectObject(ThisWorkbook, 0)
        Call 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")
        bEnableCellClick = False
    End If

End Property

Public Property Get EnableCellClickEvent() As Boolean
    EnableCellClickEvent = bEnableCellClick
End Property

Sub Start()
    EnableCellClickEvent = True
End Sub

Sub Finish()
    EnableCellClickEvent = False
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 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)
            Call SetTimer(Application.hwnd, 0, 0, AddressOf CallSetHook)
        End If
    End If
   
End Sub

Private Sub On_Close()

    Call UnInstallMouseHook
    Call KillTimer(Application.hwnd, 0)
    Call RemoveProp(GetDesktopWindow, "OleId")
    Set oWb = Nothing
    ThisWorkbook.Saved = True
    DoEvents
    Application.OnTime Now, "CloseRemoteXL"
   
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)
        lMouseHook = 0
        bHookIsSet = False
    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_LBUTTONUP = &H202

    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 CallOn_ClickEvent)
        End If
    End If
    MouseProc = CallNextHookEx(lMouseHook, ncode, wParam, ByVal lparam)
   
End Function

Private Sub CallOn_ClickEvent()

    Static oPrevctiveCell As Range
    Dim tPt As POINTAPI
   
    On Error Resume Next
   
    Call KillTimer(Application.hwnd, 0)
    Call 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

Private Sub CloseRemoteXL()
    Application.Quit
End Sub



2- Code Usage example in the ThisWorkbook Module:
(Toggle cell value TRUE\FALSE upon each click... In this example, the Click Event is applicable only to cells in Range A1:A30 in Sheet1 and skips Cell A10 because it has Data Validation)

VBA Code:
Option Explicit

Private Const TARGET_RANGE = "A1:A30"    '<== change these Consts as needed !
Private Const TARGET_SHEET = "Sheet1"     '<==
   

Private Sub Workbook_Activate()
    EnableCellClickEvent = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    EnableCellClickEvent = False
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

    If EnableCellClickEvent Then
        If Sh Is Sheets(TARGET_SHEET) Then
            If Not Application.Intersect(Target, Range(TARGET_RANGE)) Is Nothing Then
                Cancel = True
            End If
        End If
    End If

End Sub

Private Function HasValidation(ByVal Cell As Range) As Boolean
    Dim lValType As XlDVType
    On Error Resume Next
     lValType = Cell.Validation.Type
    HasValidation = Not CBool(Err.Number)
End Function


'\\===========================
 '\\ Generic OnCellClick Pseudo-Event:
 '\============================

Private Sub OnCellClick(ByVal Target As Range)

    With Target
        If .Parent Is Sheets(TARGET_SHEET) Then
            If Not HasValidation(Target) Then
                If Not Application.Intersect(Target, Range(TARGET_RANGE)) Is Nothing And .Count = 1 Then
                    .HorizontalAlignment = xlCenter
                    .Font.Color = vbRed
                    .Value = IIf(.Text <> "TRUE", "TRUE", "FALSE")
                End If
            End If
        End If
    End With

End Sub


This topic was recently discussed on this thread : Trapping left mouse click event.
 
Upvote 0
One last thing :

I am adding this new Boolean Property (RemoteApplication) whose purpose is to check if we are dealing with the current application or we are dealing with the remote hidden one.

This verification step is actually an important one because it is required to skip any other unrelated code that the user may already have in the Workbook_Avtivate and Workbook_BeforeClose event handlers.

We don't want to have any event code executed inadvertently when the workbook is opened\activated\closed in the hidden remote excel instance..

Setting Application.Events to False in the remote instance doesn't work until the workbook is already open which is no good hence, the need to add this new Property in the basMod Module :
VBA Code:
Public Property Get RemoteApplication(ByVal App As Application) As Boolean
    RemoteApplication = Not App.Visible
End Property

And then use the Property in the ThisWorkbook Module before enabling\disabling the cell click event as follows:
VBA Code:
Private Sub Workbook_Activate()
    If RemoteApplication(Application) Then Exit Sub
    EnableCellClickEvent = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If RemoteApplication(Application) Then Exit Sub
    EnableCellClickEvent = False
End Sub

I have updated the previous downloadable workbook example with this important last change.
 
Upvote 0
For the sake of completness, here is yet another more robust workaround I wrote recently for trapping cell mouse clicks which doesn't use win32 mouse hooks or timers
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,236
Members
448,555
Latest member
RobertJones1986

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