Animate Text Size with Excel VBA

Question

My goal is to increase the font size of a textbox in Excel using VBA. While that's easy, what makes this problem a bit more interesting is that I need a smooth transition from font size x to font size y--an animation.

I am currently using the following code:

Option Explicit

Sub AnimateHit()
    Dim i As Integer
    For i = 1 To 25
        ActiveSheet.Shapes.Range(Array("textEnemyHit")).Select
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = i * 10
        'Waits for 50ms
        Call DelayMs(550)
        Application.ScreenUpdating = True
    Next
End Sub

'Code from http://stackoverflow.com/questions/18602979/how-to-give-a-time-delay-of-less-than-one-second-in-excel-vba
Private Sub DelayMs(ms As Long)
    Debug.Print TimeValue(Now)
    Application.Wait (Now + (ms * 0.00000001))
    Debug.Print TimeValue(Now)
End Sub

This code works if the delay is 600ms or more. However, under 600ms, the code does not work. There is a jump from the minimum font size to the maximum without a smooth transition.

Any ideas on how I can achieve a smooth transition at a faster frame rate?

Thanks!

Excel is very slow at communicating with the GUI so you need to optimize your code as much as possible. Remove the debug.prints, don't select the shape each time in the loop set a variable for it at the start & refer to it with that variable, don't keep setting application.screenupdating — Absinthe, Mar 29 '16 at 07:57

score 1 · Accepted Answer · answered Mar 29 '16 at 07:55

I had your very same problem testing your macro

So I changed into this and it worked

Private Declare Function GetTickCount Lib "kernel32" () As Long

Option Explicit

Sub AnimateHit()
    Dim i As Integer
    ActiveSheet.Shapes.Range(Array("textEnemyHit")).Select
    For i = 1 To 25
        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = i * 10
        WasteTime (50)
    Next
End Sub

Sub WasteTime(Finish As Long)
' from http://www.myonlinetraininghub.com/pausing-or-delaying-vba-using-wait-sleep-or-a-loop
Dim NowTick As Long
Dim EndTick As Long

EndTick = GetTickCount + Finish
Do
    NowTick = GetTickCount
    DoEvents
Loop Until NowTick >= EndTick

End Sub

score 0 · Answer 2 · answered Mar 29 '16 at 07:19

0

Probably the problem is in your hardware. I have tried it like this and it works awesome - it animates really smooth.

Sub AnimateHit()

    Dim i As Integer
    For i = 1 To 25
        [set_fehler_tab2].Font.Size = i * 10

        Call DelayMs(50)
        Application.ScreenUpdating = True
    Next

End Sub

Private Sub DelayMs(ms As Long)
    Debug.Print TimeValue(Now)
    Application.Wait (Now + (ms * 0.00000001))
    Debug.Print TimeValue(Now)
End Sub

I am with i7, Windows7, Office 2010.

answered Mar 29 '16 at 07:19

Vityata

42,633
8
55
100

maybe it's a hardware-software combination issue as you say since I tried your very code (just changing the range reference) as well but with the same results: no animation. while the code in my answer gets animation – user3598756 Mar 29 '16 at 11:16

Animate Text Size with Excel VBA

2 Answers2