Towards a consistent Cell Click event

[Jaafar Tribak]

Hi all.

AS we know, the Worksheet_SelectionChange event fires when a cell is selected either with the mouse or with the keyboard.

I am trying to come up with an event that only fires when the cell is clicked with the mouse. So far, I 've only managed to do this :

Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type


Private Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Private Declare Function PeekMessage Lib "user32" _
Alias "PeekMessageA" _
(lpMsg As MSG, _
ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long, _
ByVal wRemoveMsg As Long) As Long

Private Declare Function WaitMessage Lib "user32" _
() As Long

Private Const PM_NOREMOVE = &H0
Private Const PM_NOYIELD = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDBLCLK = &H203

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim tMSG As MSG
    
    WaitMessage
    Call PeekMessage(tMSG, 0, 0, 0, PM_NOREMOVE + PM_NOYIELD)
    
    If tMSG.message = WM_MOUSEMOVE And tMSG.wParam = 0 Then
        MsgBox "You Clicked :" & Target.Address
    End If

End Sub

This works fine except for 2 limitations that I can't seem to work around namely :

1- Double-clicking the cell also fires the event which I don't want.

2- The event doesn't fire if the cursor is already in the cell, and one clicks that cell.

I guess I could run the PeekMessage API within a loop/Timer (specially to overcome the second limitation) but that would tie up the application too much and/or prevent other codes from running.

Any other ideas ?

 

[Jaafar Tribak]

Here is some code that subclasses the XL Desktop which surprisingly seems quite stable. In fact even if the VBE is reset the code still works and no crashing happens !

The following test will toggle the X value in Cell A1 upon each click of the cell.

1- Code in the Workbook module ( Note that the CellClick event routine must be declares PUBLIC so as to be seen by the CallBack function).

Option Explicit

Private Sub Workbook_Open()
    Call Subclass
End Sub

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

Public Sub CellClick(ByVal Target As Range)

    If Target.Address = Range("a1").Address Then
        Range("a1") = IIf(Range("a1") = "X", "", "X")
    End If

End Sub

2- Code in a Standard module :

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type


Private 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

Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
 
 Declare Function GetProp Lib "user32" _
Alias "GetPropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) 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 RemoveProp Lib "user32" _
Alias "RemovePropA" _
(ByVal hwnd As Long, _
ByVal lpString As String) As Long

Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long

Private Declare Function WindowFromPoint Lib "user32.dll" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long

Private Const GWL_WNDPROC As Long = -4
Private Const WM_PARENTNOTIFY = &H210
Private Const WM_LBUTTONDOWN = &H201


'****************
'Public routines :
'****************

Public Sub Subclass()

    Dim lWbkHwnd As Long
    Dim lDeskTopHwnd As Long
    Dim lPrevWnProc As Long
    
    
    lDeskTopHwnd = FindWindowEx _
    (Application.hwnd, 0, "XLDESK", vbNullString)
    lWbkHwnd = FindWindowEx _
    (lDeskTopHwnd, 0, "EXCEL7", vbNullString)
    
    lPrevWnProc = SetWindowLong _
        (lDeskTopHwnd, GWL_WNDPROC, AddressOf CallBackProc)
        
    SetProp Application.hwnd, "DeskTopHwnd", lDeskTopHwnd
    SetProp Application.hwnd, "OldProc", lPrevWnProc
    SetProp Application.hwnd, "ThisWBhwnd", lWbkHwnd

End Sub


Public Sub Unsubclass()

    SetWindowLong GetProp(Application.hwnd, "DeskTopHwnd") _
    , GWL_WNDPROC, GetProp(Application.hwnd, "OldProc")
    
    RemoveProp Application.hwnd, "DeskTopHwnd"
    RemoveProp Application.hwnd, "ThisWBhwnd"
    RemoveProp Application.hwnd, "OldProc"
   
End Sub



'****************
'Private routines :
'****************
Private Function CallBackProc _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
    
    
    Dim tPT As POINTAPI
    
    On Error Resume Next
    
    GetCursorPos tPT
    
    If TypeName(ActiveWindow.RangeFromPoint(tPT.x, tPT.y)) <> _
    "Range" Then GoTo CallPrevProc
    If TypeName(Selection) <> "Range" Then GoTo CallPrevProc
    If WindowFromPoint(tPT.x, tPT.y) <> _
    GetProp(Application.hwnd, "ThisWBhwnd") Then GoTo CallPrevProc
    
    Select Case Msg
    
        Case WM_PARENTNOTIFY
            If wParam = WM_LBUTTONDOWN Then
                Application.OnTime Now + TimeSerial(0, 0, 0.01), "CellClick"
            End If
    
    End Select
    
CallPrevProc:
    
    CallBackProc = CallWindowProc _
    (GetProp(Application.hwnd, "OldProc"), hwnd, Msg, wParam, ByVal lParam)
 
End Function


Private Sub CellClick()

    ThisWorkbook.CellClick ByVal Selection

End Sub

Please test in a blank workbook. Let me know how it works for you.

 

[Jaafar Tribak]

Has anybody given the example in the second post a try ? If so , I would love to know how stable the code was .

Thanks.

 

[RoryA]

Seems OK in 2010 but in 2003 it crashes Excel every time I insert a worksheet (both on Win XP).

I do have a sheet.xlt template in my 2003 install - will test without that.

 

[Jaafar Tribak]

Seems OK in 2010 but in 2003 it crashes Excel every time I insert a worksheet (both on Win XP).

I do have a sheet.xlt template in my 2003 install - will test without that.

Thanks rorya for taking the time.

Yes, you are right. I have jsut tried inserting a new worksheet and excel crashes on my machine. I'll investigate this further and see if the issue is solved.

The reason I want this to work is not so much the CellClick event per se rather I want to see if one can make subclassing in VBA stable & robust enough to be viable without the need of an external dll.

 

[Jaafar Tribak]

WOrkbook Demo

This is the best I could come up with. I created this small vb6 activeX dll whose bytes are stored within the workbook in a hidden sheet. The dll is loaded on the fly upon opening the workbook so there is no need for registering or referencing the dll in the project.

The issue that caused excel to crash when inserting a new worksheet is now solved at least during my testings. Seems quite stable now.

Code in the workbook module :

Option Explicit


Private Sub Workbook_Open()
    Call HookExcel
End Sub

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


'**********
'Click event
    Public Sub OnCellClick(ByVal Target As Range)
    
        With Target
            If .Parent Is Sheets(1) And .Address = Range("a1").Address Then
                Range("a1") = IIf(Range("a1") = "X", "", "X")
            End If
        End With
    
    End Sub
'**********

Code in a Standard module :

Option Explicit

 
Private Const DCOM_DLL_PATH_NAME As String _
= "C:\WINDOWS\system32\DirectCOM.dll"
 
Private Const JAAFAR_DLL_PATH_NAME As String _
= "C:\CellClick.dll"

'CreateObject-Replacement (FileBased)
Private Declare Function GETINSTANCE Lib "DirectCom" _
(FName As String, ClassName As String) As Object

Private Declare Function UNLOADCOMDLL Lib "DirectCom" _
(FName As String, ClassName As String) As Long

Private oSubclasser As Object


Public Sub HookExcel()

        'Create the DirectCom & CellClick dlls.
        Call CreateDlls

        'load an instance of the 'CellClick.dll' Class.
        Set oSubclasser = _
        GETINSTANCE(JAAFAR_DLL_PATH_NAME, "SubClasser")
        
        If Not oSubclasser Is Nothing Then
            'start watching user mouse clicks.
            Call oSubclasser.SubClassExcel(ThisWorkbook)
        Else
            MsgBox "Unable to load the " & _
            "'CellClick' dll.", vbInformation
        End If

End Sub

 Public Sub UnHookExcel()


    Set oSubclasser = _
    GETINSTANCE(JAAFAR_DLL_PATH_NAME, "SubClasser")
    
    On Error Resume Next
    
    oSubclasser.RemoveSubClass
    
    UNLOADCOMDLL JAAFAR_DLL_PATH_NAME, "SubClasser"
    
    If Len(Dir(JAAFAR_DLL_PATH_NAME)) <> 0 Then
        Kill JAAFAR_DLL_PATH_NAME
    End If
    
    On Error GoTo 0

End Sub

Private Sub CellClick()
   
   Call ThisWorkbook.OnCellClick(ByVal Selection)

End Sub


'Create the 'DirectCom' & 'CellClick' dll from the
'Bytes stored in the '"DllBytes" hidden worksheet.
Private Sub CreateDlls()
 
    Dim Bytes() As Byte
    Dim lFileNum As Integer
    Dim aVar
    Dim x As Long
 
    On Error Resume Next
    
    If Len(Dir(JAAFAR_DLL_PATH_NAME)) = 0 Then
    
       With Worksheets("DllBytes")
           aVar = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value
       End With
     
       ReDim Bytes(LBound(aVar) To UBound(aVar))
       For x = LBound(aVar) To UBound(aVar)
           Bytes(x) = CByte(aVar(x, 1))
       Next
    
       lFileNum = FreeFile
       Open JAAFAR_DLL_PATH_NAME For Binary As #lFileNum
           Put #lFileNum, 1, Bytes
       Close lFileNum
    
    End If
    
 If Len(Dir(DCOM_DLL_PATH_NAME)) = 0 Then
    
        Erase Bytes
        
        With Worksheets("dllBytes")
            aVar = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value
        End With
        
        ReDim Bytes(LBound(aVar) To UBound(aVar))
        For x = LBound(aVar) To UBound(aVar)
            Bytes(x) = CByte(aVar(x, 1))
        Next
        lFileNum = FreeFile
        Open DCOM_DLL_PATH_NAME For Binary As #lFileNum
            Put #lFileNum, 1, Bytes
        Close lFileNum
        
    End If
    

End Sub

 

[John_w]

Had a quick play and the cell click event works in Excel 2003 on Win XP, however Excel crashes nearly every time I edit the code (e.g. just deleting a blank line) and then save the workbook. This applies to both the code in post no. 2 and the workbook demo download.

 

[Jaafar Tribak]

Had a quick play and the cell click event works in Excel 2003 on Win XP, however Excel crashes nearly every time I edit the code (e.g. just deleting a blank line) and then save the workbook. This applies to both the code in post no. 2 and the workbook demo download.

Thanks John for taking a look.

It never crashes for me. I haven't tested it on excel 2003 though only on 2007. In fact one of the good things about the code is the fact that even in break mode or even embeeding new worksheet activeX controls shoudn't stop the subclassing or crash excel thanks to storing the original XLDESK window procedure address as a one of the application window Properties via the SetProp API.

Anyway, i'll test the code later on xecel 2003 and get back.