Would Like to Handle BeforeDoubleClick Event Or SelectionChange Event. But Not Both.

[CurtisD]

The user of a worksheet wants a certain functionality. If the user clicks a cell the font for the cell should be changed to bold. But if the user double clicks a cell he/she wants the fill color to change to red and does not want to change the font. I don't see how this can be done. Because when the user double clicks a cell the SelectionChange event sub executes first. And if it can't detect that the event was a double click it won't know to simply exit the SelectionChange event sub and allow the BeforeDoubleClick event sub to begin.

But perhaps there is a way to detect that a double click event occurred when the SelectionChange event sub begins. Does anyone know? Any suggestions on solving this would be appreciated.

 

[Jaafar Tribak]

Here is the update which now doesn't rely on the Worksheet_SelectionChange event and thus, overcoming the issue caused by keyboard cell selection.

Workbook example

Code in the ThisWorkbook Module:

Option Explicit

Private Enum MouseAction
    Click
    DoubleClick
End Enum

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
    #If Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
    #Else
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    Private Declare PtrSafe Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If

Private bDblClicked As Boolean
Private oPrev As Range
Private WithEvents CmBarsEvents As CommandBars

Private Const TARGET_SHEET_NAME = "Sheet1" '<== change target sheet name as needed.
  
  
  
Private Sub Workbook_Activate()
    Call HookCommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name = TARGET_SHEET_NAME Then
        Call HookCommandBars
    End If
End Sub

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

    If Sh.Name = TARGET_SHEET_NAME Then
        Cancel = True
        bDblClicked = True
        If Not oPrev Is Nothing Then
            If oPrev.Address = Target.Address Then
                bDblClicked = False
            End If
        End If
        Call MyMacro(Target, DoubleClick)
        Call SetKeyState(vbKeyLButton)
    End If

End Sub
  
Private Sub CmBarsEvents_OnUpdate()

    Const FRACTION = 4 '<== change this const value if needed. (experiment with 1 to 6)
    
    #If Win64 Then
        Dim t As LongLong
    #Else
        Dim t As Long
    #End If
    
    Dim tCurPos As POINTAPI
    
    If GetActiveWindow = Application.hwnd Then
        If ActiveSheet.Name = TARGET_SHEET_NAME Then
            Call GetCursorPos(tCurPos)
            If TypeName(ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y)) = "Range" Then
                t = GetTickCount
                Do: DoEvents
                Loop While GetTickCount - t <= GetDoubleClickTime / FRACTION
                If bDblClicked = False Then
                    On Error Resume Next
                    If ActiveWindow.RangeSelection.Count = 1 Then
                        If Err.Number = 0 Then
                            On Error GoTo 0
                            If GetKeyState(vbKeyLButton) Then
                                Call MyMacro(ActiveCell, Click)
                            End If
                        End If
                    End If
                Else
                    bDblClicked = False
                End If
                Call SetKeyState(vbKeyLButton)
                bDblClicked = False
                Set oPrev = ActiveCell
            End If
        End If
    End If

End Sub

Private Sub HookCommandBars()
    If CmBarsEvents Is Nothing Then
        Set CmBarsEvents = Application.CommandBars
        Call CmBarsEvents_OnUpdate
    End If
End Sub

Private Sub SetKeyState(ByVal Key As Long)
    Dim kbArray As KeyboardBytes
    
    Call GetKeyState(Key)
    Call GetKeyboardState(kbArray)
    kbArray.kbByte(Key) = 0
    Call SetKeyboardState(kbArray)
End Sub

Private Sub MyMacro(ByVal Target As Range, ByVal Action As MouseAction)
    If Action = Click Then
        Target = "Clicked"
        Debug.Print "Cell Clicked: ", Target.Address
    Else
        Target = "Dbl-Clicked"
        Debug.Print "Cell Double-Clicked: ", Target.Address
    End If
End Sub

 

[CurtisD]

Thanks for the feedback.

There is however one serious issue with the code which I didn't think about: the Click code also fires when selecting cells with keyboard navigation keys (arrow, Home, pageUpDown keys etc).

This Shouldn't happen as the Click code should fire only when carrying out a mouse click on the cell.

The Worksheet_SelectionChange event doesn't distiguish between a mouse click and a selection with keyboard keys. So I have taken a slightly different approach which I will be posting in the next post.

Thanks for letting me know. I hadn't thought of that. I appreciate your help!

 

[CurtisD]

Here is the update which now doesn't rely on the Worksheet_SelectionChange event and thus, overcoming the issue caused by keyboard cell selection.

Workbook example

Code in the ThisWorkbook Module:

Option Explicit

Private Enum MouseAction
    Click
    DoubleClick
End Enum

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
    #If Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
    #Else
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    Private Declare PtrSafe Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If

Private bDblClicked As Boolean
Private oPrev As Range
Private WithEvents CmBarsEvents As CommandBars

Private Const TARGET_SHEET_NAME = "Sheet1" '<== change target sheet name as needed.
 
 
 
Private Sub Workbook_Activate()
    Call HookCommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name = TARGET_SHEET_NAME Then
        Call HookCommandBars
    End If
End Sub

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

    If Sh.Name = TARGET_SHEET_NAME Then
        Cancel = True
        bDblClicked = True
        If Not oPrev Is Nothing Then
            If oPrev.Address = Target.Address Then
                bDblClicked = False
            End If
        End If
        Call MyMacro(Target, DoubleClick)
        Call SetKeyState(vbKeyLButton)
    End If

End Sub
 
Private Sub CmBarsEvents_OnUpdate()

    Const FRACTION = 4 '<== change this const value if needed. (experiment with 1 to 6)
   
    #If Win64 Then
        Dim t As LongLong
    #Else
        Dim t As Long
    #End If
   
    Dim tCurPos As POINTAPI
   
    If GetActiveWindow = Application.hwnd Then
        If ActiveSheet.Name = TARGET_SHEET_NAME Then
            Call GetCursorPos(tCurPos)
            If TypeName(ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y)) = "Range" Then
                t = GetTickCount
                Do: DoEvents
                Loop While GetTickCount - t <= GetDoubleClickTime / FRACTION
                If bDblClicked = False Then
                    On Error Resume Next
                    If ActiveWindow.RangeSelection.Count = 1 Then
                        If Err.Number = 0 Then
                            On Error GoTo 0
                            If GetKeyState(vbKeyLButton) Then
                                Call MyMacro(ActiveCell, Click)
                            End If
                        End If
                    End If
                Else
                    bDblClicked = False
                End If
                Call SetKeyState(vbKeyLButton)
                bDblClicked = False
                Set oPrev = ActiveCell
            End If
        End If
    End If

End Sub

Private Sub HookCommandBars()
    If CmBarsEvents Is Nothing Then
        Set CmBarsEvents = Application.CommandBars
        Call CmBarsEvents_OnUpdate
    End If
End Sub

Private Sub SetKeyState(ByVal Key As Long)
    Dim kbArray As KeyboardBytes
   
    Call GetKeyState(Key)
    Call GetKeyboardState(kbArray)
    kbArray.kbByte(Key) = 0
    Call SetKeyboardState(kbArray)
End Sub

Private Sub MyMacro(ByVal Target As Range, ByVal Action As MouseAction)
    If Action = Click Then
        Target = "Clicked"
        Debug.Print "Cell Clicked: ", Target.Address
    Else
        Target = "Dbl-Clicked"
        Debug.Print "Cell Double-Clicked: ", Target.Address
    End If
End Sub

Thank you so much. I really appreciate your efforts. Sincerely, Curtis