Excel VBAでテキストサイズをアニメ化する

Question

私の目標は、VBAを使用してExcelでテキストボックスのフォントサイズを大きくすることです。これは簡単ですが、この問題をもう少し面白くするのは、フォントサイズ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 

遅延が600msの以上である場合を作品このコードは。しかし、600ms未満では、コードは機能しません。スムーズに移行することなく、最小フォントサイズから最大サイズへのジャンプがあります。

より速いフレームレートでスムーズに移行するためのアイデアはありますか？

ありがとうございます！

Answer 1

私は、だから私は、これに変更し、それはExcelがある

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

問題はおそらくあなたのハードウェアにあります。私はこれをこのように試してみました。それはすごくうまくいきます。

私はi7のと思います

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 

、のWindows7、オフィス2010