Excel ile Metin Boyutunu Animasyon VBA

Question

Amacım, VBA kullanarak Excel'de bir metin kutusunun yazı tipi boyutunu arttırmaktır. Bu kadar kolay olsa da, bu problemi biraz daha ilginç kılan şey, yazı büyüklüğünden x font büyüklüğüne doğru bir geçişe ihtiyacım olmasıdır - bir animasyon. Gecikme 600 ms veya daha fazla ise

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 

Bu kod çalışır:

Şu anda aşağıdaki kodu kullanıyorum. Ancak, 600 ms altında kod çalışmaz. Minimum yazı tipi boyutundan sorunsuz geçiş yapmadan maksimum bir sıçrama vardır.

Daha hızlı bir kare hızında düzgün geçişi nasıl başarabileceğime dair herhangi bir fikir var mı?

Teşekkürler!

Answer 1

Excel

Bu yüzden bu dönüştü ve

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

Muhtemelen sorun donanımınızda. Bunu böyle denedim ve harika çalışıyor - gerçekten pürüzsüz hareket ediyor.

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 

Ben i7 ile beraberim, Windows7, Ofis 2010. Ben senin çok aynı sorunu test vardı