Double Click Event on Shapes

Question

In my research, I've found that there is no built in functionality for enabling double click events on Shapes on an excel sheet. Many of the workarounds I saw involved writing classes or other such things to add this functionality, all of which seemed a bit beyond my VBA knowledgebase. Hence, I wrote the above code (currently just as a test) to attempt to write my own Double click functionality for shapes.

Public Clicked As Boolean, LastClickObj As String, LastClickTime As Date


Sub GenerateShapes()
    Dim sheet1 As Worksheet, shape As shape
    Set sheet1 = ThisWorkbook.Worksheets("Sheet1")
    Set shape = sheet1.Shapes.AddShape(msoShapeDiamond, 50, 50, 5, 5)
        shape.OnAction = "ShapeDoubleClick"
    Set shape = sheet1.Shapes.AddShape(msoShapeRectangle, 50, 60, 5, 5)
        shape.OnAction = "ShapeDoubleClick"
    LastClickTime = Now
End Sub


Sub ShapeDoubleClick()

    If Second(Now) - Second(LastClickTime) > 0.5 Then
        Clicked = False
        LastClickObj = ""
        LastClickTime = Now
    Else

        If Not Clicked Then
            Clicked = True
            LastClickObj = Application.Caller
        ElseIf LastClickObj = Application.Caller Then
            MsgBox ("Double Click")
            Clicked = False
            LastClickObj = ""
            LastClickTime = Now - 1
        Else
            LastClickObj = Application.Caller
            Clicked = True
            LastClickTime = Now
        End If
    End If


End Sub

However, given the way I've encorporated the timer, the code often will only execute the "Double click" if I click three times in rapid succession. I think it has something to do with how I am handling the time-out "resetting" of Clicked, but there could be other issues with the logic. Any ideas on how to properly implement this functionality without other extensive additions (like Classes and such)?

Custody

Answer 1

Spent some more time looking at this and realized with some debugging that the triple click was caused by my clicked boolean. The solution I have below works perfectly, including shape distinctions, and the click delay can be easily adjusted in the code (I may adjust that to be a variable set elsewhere, but for now hardcode functionality is sufficient). Posting my solution here for future users who wish to add Double Click actions to their shapes

Option Explicit

Public LastClickObj As String, LastClickTime As Date

Sub ShapeDoubleClick()

    If LastClickObj = "" Then
        LastClickObj = Application.Caller
        LastClickTime = CDbl(Timer)
    Else
        If CDbl(Timer) - LastClickTime > 0.25 Then
            LastClickObj = Application.Caller
            LastClickTime = CDbl(Timer)
        Else
            If LastClickObj = Application.Caller Then
                MsgBox ("Double Click")
                LastClickObj = ""
            Else
                LastClickObj = Application.Caller
                LastClickTime = CDbl(Timer)
            End If
        End If
    End If

End Sub

Custody

Ha! I also figured the clicked was the problem for triple clicking - nice solution you found. It was a good puzzle! – Martyrology

@DavidG Chose to use a timer because it takes the time since midnight in seconds (thus the only possible trip-up can happen if two clicks cross midnight which is highly unlikely in this usage) – Custody

Answer 2

EDIT 3: I used your initial format with no tracker cells for this: I think it rounds up the time so you'd have to use the syntax I used above to get it to work in milliseconds. Prevents triple clicking from activating 2 double clicks.

Sub ShapeDoubleClick()

    Debug.Print Second(Now) - Second(LastClickTime)

    If Second(Now) - Second(LastClickTime) > 0.3 Then
        LastClickTime = Now

    ElseIf LastClickObj = Application.Caller And Clicked = False Then

            Debug.Print "Double Clicked!"
            Clicked = True
            LastClickTime = Now - 1
            LastClickObj = Application.Caller
            Exit Sub

    End If

    Clicked = False
    LastClickObj = Application.Caller
End Sub

Martyrology

Meant to remove that tracker cell (was just there while i was debugging since the msgbox interrupts the macro). The trouble here is that this won't require the double click to occur on the same object (which is necessary since the final implementation will contain a plethora of generated shapes) – Custody

Easy replacement for the tracker cell is just another public variable representing the last time, so that's an easy fix – Custody

Also, i dont think this will work correctly if Now is only passing in whole second values. Are you aware of whether or not it includes fractions of seconds? – Custody

See my edit. Only problem now is when it goes over 60 and that anything under 1 second works as double click. – Martyrology

Answer 3

Change to If (Now() - LastClickTime) * 86400 * 2 > 1 Then LastClickTime = Now which I believe gives half a second to double-click. Thanks this was really useful. I was always irritated that when a pivot cell is double-clicked and a new sheet opens then if you move away from that sheet it stays unconditionally and has to be deleted intentionally later. Now I use a workbook event to add a shape/note to the newly generated sheet warning "This sheet will be automatically deleted if closed. To prevent this you can add underscore after the name or change the name so first 5 characters are not 'Sheet'. Double-click this note to delete this note." On exit from the sheet an option to delete it is given immediately if the name hasn't been changed.

Honestly

Answer 4

Static Sub DCWHATEVERYOUWANTTORUN()

Dim Num As Integer
Dim MyTime As Long
Dim MyTime2 As Long
Dim MyTimeDif As Long


    If Num = 0 Then
        Num = Num + 1
        MyTime = (Hour(Time) * 60 + Minute(Time)) * 60 + Second(Time)
        Exit Sub
    ElseIf Num = 1 Then
        Num = Num - 1
        MyTime2 = (Hour(Time) * 60 + Minute(Time)) * 60 + Second(Time)
        MyTimeDif = MyTime2 - MyTime
        End If
    If MyTimeDif > 1 Then
        MyTime = MyTime2
        Num = Num + 1
        Exit Sub
    ElseIf MyTimeDif <= 1 Then
        Call WHATEVERYOUWANTTORUN
    End If


End Sub

Catheterize