I used DoEvents to provide a 1 second delay in the VBA execution, to display the countdown in timer properly.
The code used was:
time2 = Now + TimeValue("00:00:01")
Do Until Now >= time2
DoEvents
Loop
I used the above code within another Do Until Loop. The code is showing the countdown, but the delay between each time slightly varies especially for the part displayed within the nested Do Until Loop!!
The rest of the code is:
Sub btnStart_Click()
Dim time_2 As Variant
g_position = True
If g_position = True Then
UserForm1.StartUpPosition = 0
UserForm1.Left = Application.Left + 0.5 * Application.Width + UserForm1.Width + 72
UserForm1.Top = Application.Top + (0.5 * Application.Height) - (UserForm1.Height) - 36
End If
start = Now
timeEnd = start + TimeValue("00:00:10")
g_start = Format(start, "hh:mm:ss")
g_timeEnd = Format(timeEnd, "hh:mm:ss")
time_duration = timeEnd - start
g_time_duration = Format(time_duration, "hh:mm:ss")
Label1.Visible = True
time_left.Caption = g_time_duration
time_left.Visible = True
btnStart.Visible = False
time_2 = Now + TimeValue("00:00:01")
Do Until Now >= time_2
DoEvents
Loop
g_temp = Format(temp, "hh:mm:ss")
etime = start + TimeValue("00:00:01")
time_duration = timeEnd - etime
g_time_duration = Format(time_duration, "hh:mm:ss")
time_left.Caption = g_time_duration
time_2 = Now + TimeValue("00:00:01")
Do Until Now >= time_2
DoEvents
Loop
Call modtimer.time_count(time_duration, etime, timeEnd, g_time_duration)
End Sub
The Module Code:
Sub time_count(time_duratn As Variant, etim As Variant, timEnd As Variant, g_time_duratn As Variant)
temp_end = Format(TimeValue("00:00:00"), "hh:mm:ss")
temp_alert = Format(TimeValue("00:00:05"), "hh:mm:ss")
etim = etim + TimeValue("00:00:01")
time_duratn = timEnd - etim
g_time_duratn = Format(time_duratn, "hh:mm:ss")
UserForm1.time_left.Caption = g_time_duratn
time2 = Now + TimeValue("00:00:01")
Do Until Now >= time2
DoEvents
Loop
Do Until g_time_duratn = temp_end
If g_time_duratn = temp_alert Then
Beep
MsgBox "Only 5 minutes remaining", vbInformation
End If
etim = etim + TimeValue("00:00:01")
time_duratn = timEnd - etim
g_time_duratn = Format(time_duratn, "hh:mm:ss")
UserForm1.time_left.Caption = g_time_duratn
time2 = Now + TimeValue("00:00:01")
Do Until Now >= time2
DoEvents
Loop
Loop
End_Exam
End Sub
Why is the delay in the countdown varying? Can anybody help?
You are getting different time spans because Now, as far as I tested, as 1 second resolution in Office VBA. So, Now will always round time to last second.
Eg, you start waiting at 00:00:00.500, Now will return #00:00:00#. When time reach 00:00:01.000, Now will return #00:00:01#, so you think you get 1 second delay, but it was just 0.5! Using Now you may "measure" 1 second time delays which may vary between 0 to 1 second!
As workaround, WinAPI GetLocalTime may be used to get 1 milisecond resolution timestamps:
Private Declare Sub GetLocalTime Lib "Kernel32" (lpSystemTime As Any)
Function Now_ms() As Date
Dim st(0 To 7) As Integer
GetLocalTime st(0)
Now_ms = DateSerial(st(0), st(1), st(3)) + TimeSerial(st(4), st(5), st(6)) + st(7) / 1000# * #12:00:01 AM#
End Function
Replace Now with Now_ms, which is full compatible with Date data type and returns a better resolution timestamp (1ms).
Better resolution timestamps can be achieved using GetSystemTimePreciseAsFileTime (0.1μs) or QueryPerformanceCounter.
Related
Global time As Date
Sub countdown()
time = Now()
time = DateAdd("s", 120, time)
Do Until time < Now()
DoEvents
oSh.TextFrame.TextRange = Format((time - Now()), "ss")
Loop
End Sub
The timer starts from 60 and ends at 00. Then the same repeats. Is it possible to start the timer from 120 directly? How can we go about it?
Use DateDiff:
Global StopTime As Date
Sub countdown()
StopTime = DateAdd("s", 120, Now)
Do Until StopTime < Now
DoEvents
oSh.TextFrame.TextRange = DateDiff("s", Now, StopTime)
Loop
End Sub
Format will simply read the seconds from a date value, there is no way to "force" it to calculate the total seconds. However, it is rather easy to calculate it manually:
Dim delta as Date
delta = t - now
oSh.TextFrame.TextRange = Minute(d) * 60 + Second(d)
' or, if you want to have always 3 digits, eg 030
oSh.TextFrame.TextRange = Format(Minute(d) * 60 + Second(d), "000")
My program constantly updates a shape's position, based on another manipulable shape. Without DoEvents, GotoSlide, .AddShape, or increasing slideshowwindow, the screen will not refresh, and will only show the end result of the shape's position. I can't use DoEvents because it slows down too much when the mouse is moved, and I can't use GotoSlide, .AddShape, or similar methods because they don't allow the user to click in the PowerPoint (will either ignore or crash the program).
Please note, the workarounds here How to refresh the active Slide in a slide show? cause the problems I noted above (.AddShape, GotoSlide, and increasing slideshowwindow all crash the program if the mouse clicks)
I have experimented with GetQueueStaus and GetInputState as a means to filter out certain events from DoEvents, but neither seem to apply. And using them to only DoEvents when necessary obviously isn't an option because it will always be necessary when the shape is moving, and the movement will always slow down based on mouse movement during DoEvents.
Finally, I have also experimented with charts because they are the only shape in PowerPoint that has .refresh functionality, but I both was unable to get this to work, and decided that it wasn't worth the time because the shape of the chart will always be restricted to a rectangle (too limited for what I want my program to do).
Here is my code: (I am currently using GotoSlide method)
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Sub Aloop()
Dim Q As Shape
Dim B As Shape
Dim TotalTime As Long
Dim StartTime As Long
Dim TimerTextRange As TextRange
Dim A As Shape
Const PI = 3.14159265359
Set A = ActivePresentation.Slides(1).Shapes("A")
Set SldOne = ActivePresentation.Slides(1)
Set Q = ActivePresentation.Slides(1).Shapes("Q")
Set B = ActivePresentation.Slides(1).Shapes("B")
Set TimerTextRange = ActivePresentation.Slides(1).Shapes("TimerTextRange") _
.TextFrame.TextRange
TotalTime = 0
StartTime = Timer
With TimerTextRange
.Text = Int(TotalTime + (Timer - StartTime))
End With
Do While TimerTextRange.Text < 10
With TimerTextRange
.Text = Int(TotalTime + (Timer - StartTime))
End With
If Q.Left < A.Left Then
Q.Left = Q.Left + 1
ElseIf Q.Left > A.Left Then
Q.Left = Q.Left - 1
Else
End If
If Q.Top < A.Top Then
Q.Top = Q.Top + 1
ElseIf Q.Top > A.Top Then
Q.Top = Q.Top - 1
Else
End If
If GetAsyncKeyState(vbKeyD) Then
A.Left = A.Left + 4
Else
End If
If GetAsyncKeyState(vbKeyW) Then
A.Top = A.Top - 4
Else
End If
If GetAsyncKeyState(vbKeyS) Then
A.Top = A.Top + 4
Else
End If
If GetAsyncKeyState(vbKeyA) Then
A.Left = A.Left - 4
Else
End If
With Q
If (-A.Top + (.Top + .Width / 2)) > 0 Then
.Rotation = ((Atn(((A.Left + A.Width / 2) - ((.Left + .Width / 2))) / (-(A.Top + A.Height / 2) + ((.Top + .Width / 2))))) * 180 / PI)
ElseIf (-A.Top + (.Top + .Width / 2)) < 0 Then
.Rotation = ((Atn(((A.Left + A.Width / 2) - ((.Left + .Width / 2))) / (-(A.Top + A.Height / 2) + ((.Top + .Width / 2))))) * 180 / PI) + 180
Else
End If
End With
ActivePresentation.SlideShowWindow.View.GotoSlide (1)
Loop
End Sub
The code makes shape Q follow shape A around the screen, and the user can control shape a with W A S D keyboard inputs.
!!Be careful not to click the slide while the code is running, or the program will crash!!
i want to repeat an event after a certain duration that is less than 1 second. I tried using the following code
Application.wait Now + TimeValue ("00:00:01")
But here the minimum delay time is one second. How to give a delay of say half a seond?
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:
Sub test()
Dim i As Long
For i = 1 To 10
Debug.Print Now()
Sleep 500 'wait 0.5 seconds
Next i
End Sub
I found this on another site not sure if it works or not.
Application.Wait Now + 1/(24*60*60.0*2)
the numerical value 1 = 1 day
1/24 is one hour
1/(24*60) is one minute
so 1/(24*60*60*2) is 1/2 second
You need to use a decimal point somewhere to force a floating point number
Source
Not sure if this will work worth a shot for milliseconds
Application.Wait (Now + 0.000001)
call waitfor(.005)
Sub WaitFor(NumOfSeconds As Single)
Dim SngSec as Single
SngSec=Timer + NumOfSeconds
Do while timer < sngsec
DoEvents
Loop
End sub
source
Timing Delays in VBA
I have try this and it works for me:
Private Sub DelayMs(ms As Long)
Debug.Print TimeValue(Now)
Application.Wait (Now + (ms * 0.00000001))
Debug.Print TimeValue(Now)
End Sub
Private Sub test()
Call DelayMs (2000) 'test code with delay of 2 seconds, see debug window
End Sub
Everyone tries Application.Wait, but that's not really reliable. If you ask it to wait for less than a second, you'll get anything between 0 and 1, but closer to 10 seconds. Here's a demonstration using a wait of 0.5 seconds:
Sub TestWait()
Dim i As Long
For i = 1 To 5
Dim t As Double
t = Timer
Application.Wait Now + TimeValue("0:00:00") / 2
Debug.Print Timer - t
Next
End Sub
Here's the output, an average of 0.0015625 seconds:
0
0
0
0.0078125
0
Admittedly, Timer may not be the ideal way to measure these events, but you get the idea.
The Timer approach is better:
Sub TestTimer()
Dim i As Long
For i = 1 To 5
Dim t As Double
t = Timer
Do Until Timer - t >= 0.5
DoEvents
Loop
Debug.Print Timer - t
Next
End Sub
And the results average is very close to 0.5 seconds:
0.5
0.5
0.5
0.5
0.5
Obviously an old post, but this seems to be working for me....
Application.Wait (Now + TimeValue("0:00:01") / 1000)
Divide by whatever you need. A tenth, a hundredth, etc. all seem to work. By removing the "divide by" portion, the macro does take longer to run, so therefore, with no errors present, I have to believe it works.
No answer helped me, so I build this.
' function Timestamp return current time in milliseconds.
' compatible with JSON or JavaScript Date objects.
Public Function Timestamp () As Currency
timestamp = (Round(Now(), 0) * 24 * 60 * 60 + Timer()) * 1000
End Function
' function Sleep let system execute other programs while the milliseconds are not elapsed.
Public Function Sleep(milliseconds As Currency)
If milliseconds < 0 Then Exit Function
Dim start As Currency
start = Timestamp ()
While (Timestamp () < milliseconds + start)
DoEvents
Wend
End Function
Note : In Excel 2007, Now() send Double with decimals to seconds, so i use Timer() to get milliseconds.
Note : Application.Wait() accept seconds and no under (i.e. Application.Wait(Now()) ↔ Application.Wait(Now()+100*millisecond)))
Note : Application.Wait() doesn't let system execute other program but hardly reduce performance. Prefer usage of DoEvents.
Otherwise you can create your own function then call it. It is important to use Double
Function sov(sekunder As Double) As Double
starting_time = Timer
Do
DoEvents
Loop Until (Timer - starting_time) >= sekunder
End Function
To pause for 0.8 of a second:
Sub main()
startTime = Timer
Do
Loop Until Timer - startTime >= 0.8
End Sub
Public Function CheckWholeNumber(Number As Double) As Boolean
If Number - Fix(Number) = 0 Then
CheckWholeNumber = True
End If
End Function
Public Sub TimeDelay(Days As Double, Hours As Double, Minutes As Double, Seconds As Double)
If CheckWholeNumber(Days) = False Then
Hours = Hours + (Days - Fix(Days)) * 24
Days = Fix(Days)
End If
If CheckWholeNumber(Hours) = False Then
Minutes = Minutes + (Hours - Fix(Hours)) * 60
Hours = Fix(Hours)
End If
If CheckWholeNumber(Minutes) = False Then
Seconds = Seconds + (Minutes - Fix(Minutes)) * 60
Minutes = Fix(Minutes)
End If
If Seconds >= 60 Then
Seconds = Seconds - 60
Minutes = Minutes + 1
End If
If Minutes >= 60 Then
Minutes = Minutes - 60
Hours = Hours + 1
End If
If Hours >= 24 Then
Hours = Hours - 24
Days = Days + 1
End If
Application.Wait _
( _
Now + _
TimeSerial(Hours + Days * 24, Minutes, 0) + _
Seconds * TimeSerial(0, 0, 1) _
)
End Sub
example:
call TimeDelay(1.9,23.9,59.9,59.9999999)
hopy you enjoy.
edit:
here's one without any additional functions, for people who like it being faster
Public Sub WaitTime(Days As Double, Hours As Double, Minutes As Double, Seconds As Double)
If Days - Fix(Days) > 0 Then
Hours = Hours + (Days - Fix(Days)) * 24
Days = Fix(Days)
End If
If Hours - Fix(Hours) > 0 Then
Minutes = Minutes + (Hours - Fix(Hours)) * 60
Hours = Fix(Hours)
End If
If Minutes - Fix(Minutes) > 0 Then
Seconds = Seconds + (Minutes - Fix(Minutes)) * 60
Minutes = Fix(Minutes)
End If
If Seconds >= 60 Then
Seconds = Seconds - 60
Minutes = Minutes + 1
End If
If Minutes >= 60 Then
Minutes = Minutes - 60
Hours = Hours + 1
End If
If Hours >= 24 Then
Hours = Hours - 24
Days = Days + 1
End If
Application.Wait _
( _
Now + _
TimeSerial(Hours + Days * 24, Minutes, 0) + _
Seconds * TimeSerial(0, 0, 1) _
)
End Sub
I just want to calculate the time that Dijkstra function will take to calculate shortest path for source node as the network nodes are in Q
Do While True
Dim dist As Integer = Integer.MaxValue
For i = 1 To Q.Count
If Q.Item(i).dist < dist Then
dist = Q.Item(i).dist
u = Q.Item(i)
End If
Next i
If dist = Integer.MaxValue Then Exit Do 'no more nodes available - done!
Q.Remove(u.name_t)
'loop over neighbors of u that are in Q
For j = 1 To Q.Count
For Each train In trains
If train.src.name_t = u.name_t And train.dst.name_t = Q.Item(j).name_t Then
alt = u.dist + train.t
If alt < Q.Item(j).dist Then
Q.Item(j).dist = alt
Q.Item(j).prev = u
End If
End If
Next
Next
Loop
try with this
Dim starttime As DateTime
Dim endtime As DateTime
Dim elapsed As Double
starttime = Format(Now(), "hh:mm:ss") 'beginning
'your code here
endtime = Format(Now(), "hh:mm:ss") 'end
Elapsed = DateDiff("s", starttime, endtime)
MsgBox("Finished in " & Elapsed & " seconds")
**EDIT 2 **
Sub time()
startTime = Timer
endtime = Timer
totalTime = Format(finishTime - startTime, "ss")
End Sub
Get the system date-time before and after function execution, then calculate the difference.
Excel VBA 2010:
We have schedules that run 24/7. I'd like some logic to test if the break/lunch start/end times fall within the shift start/end times. I don't want someone to schedule a break outside of their scheduled shift hours.
In addition I'd like to check if a break/lunch will run into another break or lunch duration. I don't want someone to schedule a break at say 10:00-10:15 while they have lunch schedule from 10:00 to 10:30.
Thank you in advance!
Here's a sample of my logic:
ShiftStart = Format("20:45", "hh:mm")
Brk1Start = Format("23:00", "hh:mm")
Brk1End = Format("23:15", "hh:mm")
Brk2Start = Format("04:15", "hh:mm")
Brk2End = Format("04:30", "hh:mm")
LunchBrk = Format("02:00", "hh:mm")
LunchBrkEnd = Format("03:00", "hh:mm")
ShiftEnd = Format("06:15", "hh:mm")
If Brk1Start <= ShiftStart Or Brk1Start >= ShiftEnd Or _
Brk1End <= ShiftStart Or Brk1End >= ShiftEnd Then
HighlightRed
End If
Here you are!
Sub TestSchedule()
ShiftStart = CDate("20:45")
Brk1Start = CDate("23:00")
Brk1End = CDate("23:15")
Brk2Start = CDate("04:15")
Brk2End = CDate("04:30")
LunchBrk = CDate("02:00")
LunchBrkEnd = CDate("03:00")
ShiftEnd = CDate("06:15")
MsgBox IsWithin(ShiftStart, ShiftEnd, Brk1Start, Brk1End)
MsgBox IsWithin(ShiftStart, ShiftEnd, Brk2Start, Brk2End)
MsgBox IsWithin(ShiftStart, ShiftEnd, LunchBrk, LunchBrkEnd)
MsgBox IsWithin(ShiftStart, ShiftEnd, Brk1Start, Brk1End) And _
IsWithin(ShiftStart, ShiftEnd, Brk2Start, Brk2End) And _
IsWithin(ShiftStart, ShiftEnd, LunchBrk, LunchBrkEnd)
End Sub
Function IsWithin(dShiftStart, ByVal dShiftEnd, ByVal dBreakStart, ByVal dBreakEnd)
If dShiftEnd < dShiftStart Then dShiftEnd = dShiftEnd + 1
If dBreakEnd < dBreakStart Then dBreakEnd = dBreakEnd + 1
If dBreakStart < dShiftStart Then
dBreakStart = dBreakStart + 1
dBreakEnd = dBreakEnd + 1
End If
IsWithin = (dBreakStart > dShiftStart) And (dBreakEnd < dShiftEnd)
End Function
UPDATEIn reply to your question in comment here is one more function Function IsSeparate() to check if two breaks are not overlapping, also Sub Test() preparing initial data nested arrays, and Sub CheckSchedule() performing all necessary checks.
Sub Test()
Dim ShiftStart, Brk1Start, Brk1End, Brk2Start, Brk2End, LunchBrk, LunchBrkEnd, ShiftEnd, arrBrk1, arrBrk2, arrLunch, arrBrks
' set time valuse
ShiftStart = CDate("20:45")
Brk1Start = CDate("23:00")
Brk1End = CDate("23:15")
Brk2Start = CDate("04:15")
Brk2End = CDate("04:30")
LunchBrk = CDate("02:00")
LunchBrkEnd = CDate("03:00")
ShiftEnd = CDate("06:15")
' push breaks into arrays
arrBrk1 = Array(Brk1Start, Brk1End, "Break#1")
arrBrk2 = Array(Brk2Start, Brk2End, "Break#2")
arrLunch = Array(LunchBrk, LunchBrkEnd, "Lunch")
' push all break arrays into single consolidated array
arrBrks = Array(arrBrk1, arrBrk2, arrLunch)
' pass shift start, shift end, and the array to check
CheckSchedule ShiftStart, ShiftEnd, arrBrks
End Sub
Sub CheckSchedule(dShiftStart, dShiftEnd, arrBreaks)
Dim r, i, j
r = ""
For i = 0 to UBound(arrBreaks)
If Not IsWithin(dShiftStart, dShiftEnd, arrBreaks(i)(0), arrBreaks(i)(1)) Then r = r & arrBreaks(i)(2) & " is out of shift" & vbCrLf
For j = i + 1 to UBound(arrBreaks)
If Not IsSeparate(arrBreaks(i)(0), arrBreaks(i)(1), arrBreaks(j)(0), arrBreaks(j)(1)) Then r = r & arrBreaks(i)(2) & " and " & arrBreaks(j)(2) & " are overlapping" & vbCrLf
Next
Next
If r = "" Then r = "No issues were found"
MsgBox r
End Sub
Function IsSeparate(dStart1, dEnd1, dStart2, dEnd2)
Select Case True
Case dEnd1 < dStart1 And dEnd2 < dStart2
IsSeparate = False
Case dEnd1 < dStart1
IsSeparate = dEnd2 < dStart1 And dStart2 > dEnd1
Case dEnd2 < dStart2
IsSeparate = dEnd1 < dStart2 And dStart1 > dEnd2
Case Else
IsSeparate = dEnd1 < dStart2 Or dEnd2 < dStart1
End Select
End Function
Function IsWithin(dShiftStart, ByVal dShiftEnd, ByVal dBreakStart, ByVal dBreakEnd)
If dShiftEnd < dShiftStart Then dShiftEnd = dShiftEnd + 1
If dBreakEnd < dBreakStart Then dBreakEnd = dBreakEnd + 1
If dBreakStart < dShiftStart Then
dBreakStart = dBreakStart + 1
dBreakEnd = dBreakEnd + 1
End If
IsWithin = dBreakStart > dShiftStart And dBreakEnd < dShiftEnd
End Function