Excel VBA - How do I Create a Button Depressed Effect for a Custom Macro Shape Button?-CodePudding

I have created a custom shape to use as a Macro button in Excel. Initially, I was using the default Excel macro button, but wanted to make the spreadsheet look more modern. I have achieved what I was seeking in that regard, but now the buttons do not provide any feedback when you click them- they just load the Macro. With the original buttons, pressing them would provide a depression effect. I would like to simulate this effect with the new shape.

After searching solutions on the internet, I found one that worked.. once. It simulated a button click for a fraction of a second and loaded the macro. After the first use, it stopped working all together. I tried creating a new subroutine, but it did not help. I also added a sleep step at the recommendation of the site I found it on, and it did not have any effect either. Here's the code I am using:

Sub SimulateButtonClick2()
Dim vTopType As Variant
Dim iTopInset As Integer
Dim iTopDepth As Integer

'Record original button properties
    With ActiveSheet.Shapes(Application.Caller).ThreeD
        vTopType = .BevelTopType
        iTopInset = .BevelTopInset
        iTopDepth = .BevelTopDepth
    End With

'Button Down
    With ActiveSheet.Shapes(Application.Caller).ThreeD
        .BevelTopType = msoBevelSoftRound
        .BevelTopInset = 24
        .BevelTopDepth = 8
    End With
    Application.ScreenUpdating = True
    
      Sleep 250
    Application.ScreenUpdating = True

'Button Up - set back to original values
    With ActiveSheet.Shapes(Application.Caller).ThreeD
        .BevelTopType = vTopType
        .BevelTopInset = iTopInset
        .BevelTopDepth = iTopDepth
    End With
    
Call checker

End Sub

I am assigning this macro to the button and calling the macro I need using "Call checker" at the end.

Thank you!

CodePudding user response：

EDIT: updated to add alternative approach to pause until mouse button is released

This worked fine for me, using a loop with Timer and Doevents:

'add the 64-bit version if you need to support that...
Private Declare Function GetAsyncKeyState Lib "User32" (ByVal vKey As Long) As Long

Sub Tester()
    
    SimulateButtonClick ActiveSheet.Shapes(Application.Caller)
    
    Debug.Print "clicked!"

End Sub

'is the left mouse button down?
Function MouseIsDown() As Boolean
    MouseIsDown = GetAsyncKeyState(&H1)
End Function

Sub SimulateButtonClick(shp As shape)
    Dim vTopType As Variant, iTopInset As Integer, iTopDepth As Integer, t
    With shp.ThreeD
        vTopType = .BevelTopType 'Record original button properties
        iTopInset = .BevelTopInset
        iTopDepth = .BevelTopDepth
        .BevelTopType = msoBevelSoftRound
        .BevelTopInset = 8
        .BevelTopDepth = 8
        t = Timer

        '#1: use this loop for a temporary "pressed" effect 
        Do While Timer - t < 0.1
            DoEvents
        Loop
        'OR
        '#2: use this loop to wait until mouse button is let up
        Do While MouseIsDown
            DoEvents
            If Timer > (t   10) Then Exit Do 'in case of glitches...
        Loop

        .BevelTopType = vTopType
        .BevelTopInset = iTopInset
        .BevelTopDepth = iTopDepth
        DoEvents
    End With
End Sub