Размер анимации текста с помощью Excel VBA

Question

Моя цель - увеличить размер шрифта текстового поля в Excel с помощью VBA. Хотя это легко, что делает эту проблему немного более интересной, так это то, что мне нужен плавный переход от размера шрифта x к размеру шрифта y - анимация.

В настоящее время я использую следующий код:

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 

Этот код работает если задержка 600мс или более. Однако, до 600 мс, код не работает. Переход от минимального размера шрифта до максимума возможен без плавного перехода.

Любые идеи о том, как я могу добиться плавного перехода с более высокой частотой кадров?

Спасибо!

Answer 1

У меня был свой же проблема тестирования макросу

Так что я изменил в этом, и она работала

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 

Answer 2

Возможно, проблема в вашем оборудовании. Я пробовал это так, и он работает потрясающе - он оживляет действительно гладкий.

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 

Я с i7, Windows7, Office 2010.