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
EDIT: 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.
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
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
Related
I've got a legacy VBA function which I want to stop running if it takes longer than 3 minutes - please see below for code I have so far.
Obviously, the MsgBox only shows once function has completed but I need it to show and exit a function during.
Dim startTime As Long
startTime = GetTickCount
Do
If GetTickCount - startTime > 10000 Then
MsgBox "There seems to be an issue. Please try again!"
Exit Do
End If
doStuff
Loop
Can anyone help me out?!
Many Thanks in advance.
If the code is in that same sum you can just add Exit Sub after your msgbox.
there is here for 10 seconds
Dim startTime As Date
startTime = Now
Do
If DateDiff("s", startTime, Now) > 10 Then
MsgBox "There seems to be an issue. Please try again!"
Exit Do
End If
dostuff
Loop
But this works only if duration of dostuff is < 10 seconds. Otherwise you must put the check into dostuff
Check the TickCount inside the function:
Function doStuff()
-your code.....
If GetTickCount - startTime > 10000 Then
Exit Function
-your code.....
-your code.....
-your code.....
If GetTickCount - startTime > 10000 Then
Exit Function
End Function
If the issue is that the Function doStuff is taking too long to run, then you will definitely need an Exit in the function itself.
Without knowing what the function itself does exactly, we cannot give specific advice for that.
But for instance, if the problem is one singular query that takes too long, then the issue cannot really be avoided. If the problem is you want it to Exit in between certain running portions of your function, just place a timer / Exit clause into the function where it might hang and the timer "passes 2 minutes".
By all this I mean, switch your original code around a little bit:
If GetTickCount - startTime > 10000 Then
MsgBox "There seems to be an issue. Please try again!"
Exit Function
End If
OR (if your function runs some kind of loop in itself, you could modify the Do in the loop itself):
Do While GetTickCount - startTime > 10000
'Code here
Loop
Could anyone please tell me if and how it is possible to count time of running various modules in VBA excel?
I am only able to count the elapsed time of one single module. However, when it comes to more than 1 module it seems there is no info out there. Or I am blind.
With one module I pass Timer value to a variable set at the begining of code and then at the end. Then I deduct second variable from the first.
When I try to do it between modules initial variable value is reset to empty.
Many thanks for any pointers
Tommeck37
For a simple way to measure the time it takes to execute portions of your code, you can use the VBA timer() function. That function isn't perfect, but it's a good place to start.
Timer() returns the number of seconds that have elapsed since midnight, including fractions.
Just before you call a module, assign the result of timer() to a variable. Timer returns a Double, but you could store it in a variant, too. Then do another call to timer() just after the module. For example:
time1 = timer()
call Proc1()
time2 = timer()
call Proc2()
time3 = timer()
debug.print "Proc1 time: " & cStr(time2-time1)
debug.print "Proc2 time: " & cStr(time3-time2)
There are other timers that you can use in VBA, but they require using windows procedures, and are harder to setup and use. For gross timing, this works fine. If you want to time with millisecond accuracy (or better), then look into other ways.
I run a very simple "Snake"-like game on my excel, which means I need the screen to be updated continuously, inside my main-while loop. The "snake" (a colored cell basically) is moving randomly within a 20x20 table.
It works well for several seconds, however, ay some point screen stops updating; ans excel stops responding, while still running the code. This leads to a crash.
I remplaced while loop with a For loop, which avoids crashing, but still, the screen stops updating until the loop is ended. When the loops stops, the screen is updated one last time.
I also included "Sleep" statements after each function, however, this doesn't help.
Here is the main code:
Sub main()
Dim table(20, 20) As Integer
Dim index_move As Integer
'Position class contains only X and Y parameters
Dim index_actual_head_pos As Position
Set index_actual_head_pos = New Position
Dim i As Long
index_actual_head_pos.x = 5
index_actual_head_pos.y = 15
Application.ScreenUpdating = True
For i = 1 To 50 'this remplaces the initial while loop
'next line generates a random movement, bounded by a 20x20 matrix
index_move = generer_movement(index_actual_head_pos)
'next line updates the "snake" position params
Call update_position(index_actual_head_pos, index_move)
'next line deletes previous snake and draws a new one
Call draw(index_actual_head_pos)
Sleep (200)
Next i
End Sub
Please, note that the problem is really screen updating. As stated before, I don't know how to force excel to update screen continuously
Many thanks,
Denis
You should probably abandon that Sleep(200) and let the Excel application object do some processing for the 200 milli-seconds instead.
dim dTill as double 'should be at the top with the other var declarations
dtill = Timer + 0.200
do while timer < dTill and timer > 0.200: DoEvents: loop
The timer > 0.200 is important because Timer resets at midnight and you wouldn't want it to stall everything for 24 hours if you crossed midnight during that ¹⁄₅ second.
I have my service working mostly as it should, but it should only do it's work once every day.
To arrange this, my boss recommended I sleep the worker thread until 7am tomorrow:
This Thread.Sleep call is copied directly from a similar service he wrote that apparently works, but this always throws an ArgumentOutOfRangeException - the value returned is a negative.
Private Sub startExport()
#If Not Debug Then
Thread.Sleep(1000 * 60 * 1)
#End If
While runReportExport
Try
runExport()
Catch ex As Exception
el.WriteEntry("Error exporting data: {1}")
Finally
'sleep thread until tomorrow 7am
Thread.Sleep(DateTime.Now.Subtract(Date.Today.AddDays(1).AddHours(7)))
End Try
End While
End Sub
I'm fairly confused about how this all works so if anyone can explain the whole timespan thing for me, I'd greatly appreciate it.
On the other hand, my friend recommends I manage the thread execution in a different way.
Here's what He recommended I do:
Private lastExecute As DateTime = DateTime.Now
Private Overrides Sub OnStart(ByVal args() As String)
startService()
End Sub
Private Sub startService()
Dim nextExecute = lastExecute.AddDays(1)
If nextExecute >= DateTime.Now Then
lastExecute = DateTime.Now
tWorker = New Thread(AddressOf startExport)
tWorker.IsBackground = True
tWorker.Start()
End If
End Sub
He said this would execute the worker thread once on startup and not again for another day. While this code does work without error, it doesn't stop the service loop from executing the worker thread over and over again (currently it executes a 2nd time as soon as it finished it's first run)
Personally I'm open to either approach, I can't seem to get either working.
Basically, all I need at the end of the day is a service that exports data once daily.
My boss' Thread.Sleep option seems the simpler, but my friend's suggestion seems like better practice.
Can anyone help me to get this sorted (at this point I don't care which one I use, just so long as it works)?
DateTime.Now.Subtract(Date.Today.AddDays(1).AddHours(7)))
You subtract a future time from the current time. That always produces a negative value. Kaboom.
You'll need to invert that, subtracting the current time from the future time. Spelled out for clarity and avoiding the race on DateTime.Now :
Dim today = DateTime.Now
Dim tomorrow = today.Date.AddDays(1).AddHours(7)
Dim wait = tomorrow - today
Thread.Sleep(wait)
You will need to do something useful when the service is stopped. Best done with a ManualResetEvent, you'll get the sleep from its WaitOne(wait) method. Btw, extremely wasteful to have a thread sleep for that long and not doing anything useful. Use a Timer instead.
Another approach, and one I use, to run a specific task once a day is to set the task up in a timer. In my case I want the task to run at 12:05am each morning. Accordingly, when my program starts I set the initial interval of the timer such that the first tick will happen at 12:05 am the next day. After that, once a day, at the end of the code the executed as part of the tick I once again reset the timer interval such that the next tick will happen at 12:05am the next day.
...
Timer1.Interval = MillisecondsToMidnight() + 300000 ' next tick 12:05:00 tomorrow
...
Private Function MillisecondsToMidnight() As Integer
Dim ReturnValue As Integer
Dim ts As TimeSpan
Dim Tomorrow As DateTime = Today.AddDays(1)
ts = Tomorrow.Subtract(Now)
ReturnValue = ts.TotalMilliseconds()
ts = Nothing
Return ReturnValue
End Function
This is my first time using VBA in Outlook so please bear with me
I've created a basic Macro that does various things to folders. Since this takes a while I decided to make a status window that says what its currently doing. I simply keep setting one of the label's values with this
Function UpdateStatus(Message As String)
StatusForm.StatusUpdate.Caption = Message
StatusForm.Repaint
End Function
The issue is that after it runs for a bit (5-15 seconds) the window and the rest of outlook locks; the form no longer updates and has a "(Not Responding)" in its window title.
I feel like I'm somehow dead locking the UI thread but I'm at a loss on how to work around it. Commenting out Repaint not surprisingly doesn't let it update at all, but outside of that I don't know where to look
Any suggestions?
Try adding DoEvents in your computationally intensive loop. This yields the executing code to the UI thread so that other things can get done when you have computationally intensive stuff going on in the background. Office is single-threaded, so you can block the UI when you are running macros.
Sample:
Sub LockUI()
Dim x
x = Timer
Do While Timer - x < 5
'Blocks the UI for 5 seconds
Loop
End Sub
Sub LockUI2()
Dim x
x = Timer
Do While Timer - x < 5
'Doesn't block the UI
DoEvents
Loop
End Sub