在Excel VBA中创建毫秒循环

Question

Since I just found out about Excel Macros, I want to try to simulate moving objects. I would like to run some looped code every 'frame' of my project. I can make an infinite loop in Excel VBA with this code:

Do While True:
    'code
Loop

However, this crashes Excel. Is there a way to make an infinite loop that runs every ten milliseconds or so, something like this:

Dim timer as Timer
If timer = 10 Then
    'code
    timer = 0
End If

Your answers are very good, but not exactly what I'm looking for. I want to be able to run other code at the same time; a bit like Javascript's

setInterval(function(){}, 200);

which can run multiple functions simultaneously.

Answer 1

You can use an API call and Sleep.

Put this at the top of your module:

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Then you can call it in a procedure like this:

Do While True:

Sleep 10    'wait 0.01 seconds

Loop

If the code is in 64bit OS, you will need to use PtrSafe. See https://support.microsoft.com/en-us/help/983043/compile-error-the-code-in-this-project-must-be-updated-for-use-on-64

Answer 2

Your original method is crashing Excel because it is creating an infinite loop with no exit condition.

The second method doesn't work because your system clock time (given by Timer ) will never be 10 , if you use debug.Print(Timer) in your Immediate Window you will see its value.

Here is some commented code to execute some actions based on a timer. Please please PLEASE make sure you retain the runtime condition for exiting the while loop, infinite loops are the devil and really you should have some other exit code in here somewhere!

Sub timeloop()
    Dim start As Double: start = Timer     ' Use Timer to get current time
    Dim t As Double: t = start             ' Set current time "t" equal to start
    Dim interval As Double: interval = 1   ' Interval for loop update (seconds)
    Dim nIntervals As Long: nIntervals = 0 ' Number of intervals passed

    ' Use this While loop to avoid an infinite duration! Only runs for "runtime" seconds
    Dim runtime As Double: runtime = 10
    Do While t < start + runtime
        ' Check if a full interval has passed
        If (t - start) / interval > nIntervals Then
            nIntervals = nIntervals + 1
            ' Do stuff here ---
            Debug.Print (t)
            ' -----------------
        End If
        t = Timer ' Update current time
    Loop
End Sub