Change button appereance only while running macro

Question

I have a shape in excel which acts as a button to run a VBScript macro. I'd like to change the bevel and shadow while the macro is running to make it seem like the button was physically pressed. I feel like this should be an easy one to solve but I don't understand why my code isn't working:

Sub Welcome_Begin()
    Sheets("Welcome").Select
    With ActiveSheet.Shapes.Range(Array("Welcome_Begin_Button"))
         .ThreeD.BevelTopInset = 0
         .ThreeD.BevelTopDepth = 0
         With .Shadow
             .OffsetX = 0
             .OffsetY = 0
         End With
     End With
     Application.ScreenUpdating = False

     < code goes here >

     Sheets("Welcome").Select
     Application.ScreenUpdating = True
     With ActiveSheet.Shapes.Range(Array("Welcome_Begin_Button"))
         With .Shadow
             .OffsetX = 1.2246467991E-16
             .OffsetY = 2
         End With
         .ThreeD.BevelTopInset = 1
         .ThreeD.BevelTopDepth = 0.5
     End With
End Sub

With this code, it should change the appearance of the button before pausing screen update and running the code. I have tested the upper and lower blocks individually to ensure that the code will correctly change the appearance of the button, so I don't know why the button doesn't change before pausing screen updates...

Here's what it looks like:

This is what it should look like when pressed:

Any ideas?

Try adding `DoEvents` just before `Application.ScreenUpdating = False` — chris neilsen, Dec 20 '22 at 17:48
@chrisneilsen just `DoEvents`? Adding that before `Application.ScreenUpdating = False` didn't solve the issue — Josh Silveous, Dec 20 '22 at 18:00
Hmm. [This answer](https://stackoverflow.com/a/58993203/445425) might help — chris neilsen, Dec 20 '22 at 18:07
If you replace `< code goes here >` with (eg) `Application.Wait Now + TimeSerial(0,0,3)` you can see that the `Application.ScreenUpdating = False` is the issue, even though it follows the button update. If you comment that out the button will change appearance. I can't seem to find any way to get around that though. — Tim Williams, Dec 20 '22 at 19:17

Tim Williams · Accepted Answer · 2022-12-21T16:35:54.780

This is the best I could do, but it does add an additional 1sec delay to the run. If you try to reduce that below 1sec you will find you lose the button transition while the rest of the code is running.

Const BTN_NM As String = "Welcome_Begin_Button"

Dim runTime

'Button entry point
Sub Welcome_Begin1()
    
    If runTime <> 0 Then Exit Sub 'run already scheduled
    
    Clicked ActiveSheet.Shapes(BTN_NM)             'set button as "clicked"
    
    runTime = Now + TimeSerial(0, 0, 1)            'set global variable
    Application.OnTime runTime, "Welcome_Begin2"   'call with 1 sec delay
End Sub

'main button code here...
Sub Welcome_Begin2()
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    For i = 1 To 2000 'do something long-ish
        ActiveSheet.Range("A1").Value = i
        DoEvents
    Next i
    
    Clicked ActiveSheet.Shapes(BTN_NM), False 'reset button
    
    'might want to add an error handler to ensure this next line gets run...
    runTime = 0                               'clear scheduled time

End Sub


'format a shape as "clicked" or "not clicked"
Sub Clicked(btn As Shape, Optional IsOn As Boolean = True)
    Dim scrUpd
    scrUpd = Application.ScreenUpdating
    Debug.Print "ScreenUpdating", scrUpd
    Application.ScreenUpdating = True 'make sure this is on
    With btn
        .ThreeD.BevelTopInset = IIf(IsOn, 0, 1)
        .ThreeD.BevelTopDepth = IIf(IsOn, 0, 1.5)
        With .Shadow
            .OffsetX = IIf(IsOn, 0, 2)
            .OffsetY = IIf(IsOn, 0, 1.5)
        End With
    End With
    DoEvents
    Application.ScreenUpdating = scrUpd 'reset screenupdating
End Sub

score 0 · Answer 2 · answered Dec 24 '22 at 21:40

As suggested in a comment, adding 'DoEvents' works, the trick is you have to do it twice

Your code, refactored (plus a couple of other improvements)

Sub Welcome_Begin()
    Dim ws As Worksheet
    Dim shp As Shape
    
    Set ws = Sheets("Welcome")
    Set shp = ws.Shapes("Welcome_Begin_Button")
    ws.Activate
    With shp
        .ThreeD.BevelTopInset = 0
        .ThreeD.BevelTopDepth = 0
        With .Shadow
            .OffsetX = 0
            .OffsetY = 0
        End With
    End With
    DoEvents
    DoEvents
    
    Application.ScreenUpdating = False
    
    '< code goes here >
    
    ws.Activate
    Application.ScreenUpdating = True
    With shp
        With .Shadow
            .OffsetX = 1.2246467991E-16
            .OffsetY = 2
        End With
        .ThreeD.BevelTopInset = 1
        .ThreeD.BevelTopDepth = 0.5
    End With
End Sub

Change button appereance only while running macro

2 Answers2