I want to make an activity to happen only when there is minimum 60 seconds time gap between two successive activities. I have the below code:
Sub timediff()
Dim Psos As New Collection
Dim currtime As Date
Dim dummytime As Date
Dim diffoftime As Long
If Psos.Count = 0 Then
dummytime = "9:00:00"
Psos.Add dummytime
End If
currtime = Format(Now(), "hh:mm:ss")
diffoftime = DateDiff("s", CDate(Psos.Item(Psos.Count)), CDate(currtime))
If diffoftime > 60 Then
Debug.Print diffoftime
Psos.Add currtime
End If
End Sub
But I'm always getting the time difference from 9:00:00 to current time instead of time difference between current time and latest added collection item. Would anyone suggest the issue.
Every time you call timediff, Psos is reset to empty... Not sure why a collection is needed, just make a global Date variable and compare to it, or do everything in one procedure:
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Public Sub OneMinuteLoop()
Dim dtmNow As Date
Dim dtmLastUpdate As Date
Do While True
dtmNow = Now()
If DateDiff("s", dtmLastUpdate, dtmNow) > 30 Then
'Do something
dtmLastUpdate = dtmNow
End If
Sleep 5000
DoEvents
Loop
End Sub
Why don't you simply take the difference between two results of the Now() worksheet function, and multiply it with 86400, without any formatting?
Now() gives the datetime of now, where units are days. As there are 86400 seconds within one day, the multiplication of the difference with 86400 will give you the amount of seconds.
Related
I'm trying to make a VBA code that allows me to calculate the time ellapsed between two clicks/buttons.
Here is the scenario I'm looking for :
I select an empty cell in the column Time
I click on the START button (to start the counter)
I click on the STOP button (to stop the counter)
The ellapsed time (in the format "hh:mm:dd") has to be put in the selected cell in step 1
Expected output :
I started making a code for the START button but I don't know how the one's for the STOP button.
Sub CalculateTime()
Dim startTime As Double
Dim TimeElapsed As String
startTime = Timer
TimeElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
ActiveCell.Value = TimeElapsed
End Sub
Do you have any suggestions, please ?
Any help will be appreciated !
EDIT :
Here is the code of my two subs :
Sub StartButton()
Call CalculateTime(True)
End Sub
'**************************************
Sub StopButton()
ActiveCell.Value = CalculateTime(False)
End Sub
There are various ways to tackle this. One way is to use a global variable (startTime) which is set in your Start button click event. Your Stop button then executes your method and (sans the startTime = Time line obviously).
But I prefer to avoid global variables, so therefore you could rewrite your Sub as a Function and call it twice. Once from the Start button: Call CalculateTime(True). And once from the Stop button: ActiveCell.Value = CalculateTime(False)
Function CalculateTime(ByVal bolStart As Boolean) As String
' Declaring a local variable as Static preserves their value between calls
' of the method.
Static startTime As Double
If bolStart = True Then
' This is the start of the measurement, we simply store the time
startTime = Timer
Else
' This is the end of the measurement, so we calculate the time elapsed
' and return it as a string.
CalculateTime = Format$((Timer - startTime) / 86400, "hh:mm:ss")
End If
End Function
I am looking for a solution to call a MySub every 100 milliseconds.
MySub contains a loop with a variable length (and variable execution time).
Currently I can do this every second with this code:
Sub UPDATECLOCK()
Call MySub
NextTick = Now + TimeValue("00:00:01")
Application.OnTime NextTick, "UPDATECLOCK"
End sub
I read in the first answer in this post that it is not possible:
VB Excel Macro Millisecond Timing
Although in the second answer this solution is given:
Sub Macro2()
' Macro2 Macro
Range("C1").FormulaR1C1 = "1"
Application.Wait (Now + TimeValue("0:00:01")) '1sec
Range("C1").FormulaR1C1 = "2"
Application.Wait (Now + 0.000001) '1/10sec
Range("C2").Select
Sleep (100)
End Sub
If I understand correctly Application.Wait is added to let Excel wait for several milliseconds.
https://learn.microsoft.com/en-us/office/vba/api/excel.application.wait
Although the Excel application is frozen while using Wait which is not feasible for me.
Maybe an alternative could be to measure the time my loop takes to execute on the system clock.
I found this website https://www.aeternus.sg/best-millisecond-timer-vba/ with this code:
' Performance counter API's
#If VBA7 And Win64 Then
'for 64-bit Excel
Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#Else
'for 32-bit Excel
Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#End If
'Purpose: Measure elapsed time in milliseconds
Sub TimeACode()
Dim curFrequency As Currency
Dim curStartPerformanceCounter As Currency
Dim curEndPerformanceCounter As Currency
Dim lgResult As Long
'obtain no: of counts per second
lgResult = QueryPerformanceFrequency(curFrequency)
If lgResult > 0 Then
Debug.Print "Frequency: " & curFrequency
End If
'measure start count
lgResult = QueryPerformanceCounter(curStartPerformanceCounter)
If lgResult > 0 Then
Debug.Print "Start Count: " & curStartPerformanceCounter
End If
'*****************************************
'Insert the code to measure elapsed time
'*****************************************
'measure end count
lgResult = QueryPerformanceCounter(curEndPerformanceCounter)
If lgResult > 0 Then
Debug.Print "End Count: " & curEndPerformanceCounter
End If
'measure elapsed time
Debug.Print "Elapsed time (ms): " & (curEndPerformanceCounter - curStartPerformanceCounter) / curFrequency
End Sub
I do not understand this code very well. Although it seems to me it counts the processor ticks since the last reboot of the system. Would it be possible to alter this code in a way that it will call MySub after a certain number of ticks of the processor?
If I call this function on my system:
lgResult = QueryPerformanceFrequency(curFrequency)
The function returns 1000.
Does this mean my processor makes 1000 ticks per second?
Would it be possible to call MySub after every 100 ticks?
Thanks a lot!
I have a userform which runs a script every 100ms. The script handles images on the userform and is used to animate them, while the form continues to receive user input (mouse clicks and key presses). This continues until the userform is closed. While Application.OnTime seems to work best, it only operates consistently on time values of 1 second or more.
When I use something like
Sub StartTimer()
Application.OnTime now + (TimeValue("00:00:01") / 10), "Timer"
End Sub
Private Sub Timer()
TheUserForm.ScreenUpdate
Application.OnTime now + (TimeValue("00:00:01") / 10), "Timer"
End Sub
and call StartTimer in the userform, Excel becomes very unresponsive and "Timer" is called many more times per second than it should.
Using the Sleep function causes the program to become unresponsive too, although the script is run with the right interval.
Is there a workaround for this? Thanks in advance!
OnTime can only be scheduled to run in increments of 1 second. When you attempt to schedule it at 1/10th second, you actually schedule at 0 seconds, ie it runs again immediately, consuming all resources.
Short answer, you cannot use OnTime to run an event every 1/10 second.
There are other ways, see CPearson for using a call to Windows API
Public Declare Function SetTimer Lib "user32" ...
Try this simple hybrid method for your 'Timer' sub:
Sub Timer
Application.OnTime now + TimeValue("00:00:01"), "Timer"
t1 = Timer
Do Until Timer >= t1 + 0.9
t2 = Timer
Do Until Timer >= t2 + 0.1
DoEvents
Loop
TheUserForm.ScreenUpdate
... your code
Loop
End Sub
Of course, one problem of user the 'Timer' function is that at midnight your code may turn into a pumpkin (or crash). ;) You would need to make this smarter but if you generally only work during the day, like me, it's not a problem.
Just had this same question today. Here's the solution I was able to find that worked really well. It allows a timed event to fire on intervals as small as 1 millisecond, without taking control of the application or causing it to crash.
The one disadvantage I've been able to find is that TimerEvent() requires a blanket On Error Resume Next to ignore errors caused when it can't execute the code (like when you're editing another cell), which means it will have no idea when a legitimate error occurs.
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, _
ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, _
ByVal nIDEvent As LongPtr) As Long
Public TimerID As Long
Sub StartTimer()
' Run TimerEvent every 100/1000s of a second
TimerID = SetTimer(0, 0, 100, AddressOf TimerEvent)
End Sub
Sub StopTimer()
KillTimer 0, TimerID
End Sub
Sub TimerEvent()
On Error Resume Next
Cells(1, 1).Value = Cells(1, 1).Value + 1
End Sub
' yes it is a problem
' it stops when cell input occurs or an cancel = false dblClick
' the timer API generally bombs out EXCEL on these
' or program errors as VBA has no control over them
' this seems to work and is in a format hopefully easy to adapt to
' many simultaneous timed JOBS even an Array of Jobs.. will try it this week
' Harry
Option Explicit
Public RunWhen#, PopIntervalDays#, StopTime#
Public GiveUpDays#, GiveUpWhen#, PopTimesec#, TotalRunSec!
Public PopCount&
Public Const cRunWhat = "DoJob" ' the name of the procedure to run
Sub SetTimerJ1(Optional Timesec! = 1.2, Optional RunForSec! = 10, Optional GiveUpSec! = 20)
If Timesec < 0.04 Then Timesec = 0.05
' does about 150 per sec at .05 "
' does 50 per sec at .6 ????????????
' does 4 per sec at .9 ????????????
'iterations per sec =185-200 * Timesec ( .1 < t < .9 )
' if t >1 as int(t)
' or set Timesec about (iterationsNeeded -185)/200
'
PopTimesec = Timesec
PopIntervalDays = PopTimesec / 86400# ' in days
StopTime = Now + RunForSec / 86400#
GiveUpDays = GiveUpSec / 86400#
TotalRunSec = 0
PopCount = 0
StartTimerDoJob
End Sub
Sub StartTimerDoJob()
RunWhen = Now + PopIntervalDays
GiveUpWhen = Now + GiveUpDays
Application.OnTime RunWhen, cRunWhat, GiveUpWhen
' Cells(2, 2) = Format(" At " & Now, "yyyy/mm/dd hh:mm:ss")
'Application.OnTime EarliestTime:=Now + PopTime, Procedure:=cRunWhat, _
Schedule:=True
End Sub
Sub DoJob()
DoEvents
PopCount = PopCount + 1
'Cells(8, 2) = PopCount
If Now >= StopTime - PopIntervalDays / 2 Then ' quit DoJob
On Error Resume Next
Application.OnTime RunWhen, cRunWhat, , False
Else
StartTimerDoJob ' do again
End If
End Sub
Sub StopTimerJ1()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
schedule:=False
End Sub
I have made a code using lotusscript that would calculate the time difference between the two fields, now I want to calculate the difference between dates. I've pretty much started lotusscripting and I still got a minimum knowledge about it. Hope you can help me. Here's the code that I've made to calculate time difference:
Sub UpdateDuration()
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim starttime As NotesDateTime
Dim endtime As NotesDateTime
Dim duration As Integer
Set uidoc = ws.CurrentDocument
If uidoc.FieldGetText("StartTime") = "" Then
Exit Sub
Elseif uidoc.FieldGetText("StartTime") = "" Then
Exit Sub
End If
Set starttime = New NotesDateTime( uidoc.FieldGetText("StartTime") )
Set endtime = New NotesDateTime( uidoc.FieldGetText("EndTime") )
duration = endtime.TimeDifference( starttime )
Call uidoc.FieldSetText("Duration", Cstr(duration) )
Call uidoc.Refresh()
End Sub
TimeDifference returns the number of seconds between two NotesDateTimes. There are 60 * 60 * 24 seconds in a day, and that works out to 86400. So just write your code exactly as above and divide the result by 86400. (The only other thing you might want to change is your field and variable names, to reflect the fact that you are working with date input instead of time.)
Since performance of string concatenation is quite weak in VB6 I'm testing several StringBuilder implementations. To see how long they're running, I currently use the built-in
Timer
function which only gives me the number of seconds that have passed after midnight.
Is there a way (I guess by importing a system function) to get something with milliseconds precision?
Yes, you can use the Win32 API:
DWORD WINAPI GetTickCount(void);
To import it in VB6 declare it like this:
Private Declare Function GetTickCount Lib "kernel32" () As Long
Call it before the operation and after and then calculate the difference in time passed.
Put the following code in a Stopwatch class:
Option Explicit
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
Private m_startTime As Currency
Private m_freq As Currency
Private m_overhead As Currency
Public Sub start()
QueryPerformanceCounter m_startTime
End Sub
Public Function ElapsedSeconds() As Double
Dim currentTime As Currency
QueryPerformanceCounter currentTime
ElapsedSeconds = (currentTime - m_startTime - m_overhead) / m_freq
End Function
Public Function ElapsedMilliseconds() As Double
ElapsedMilliseconds = ElapsedSeconds * 1000
End Function
Private Sub Class_Initialize()
QueryPerformanceFrequency m_freq
Dim ctr1 As Currency
Dim ctr2 As Currency
QueryPerformanceCounter ctr1
QueryPerformanceCounter ctr2
m_overhead = ctr2 - ctr1
End Sub
You can use it as follows:
Dim sw as StopWatch
Set sw = New StopWatch
sw.Start
' Code you want to time
Debug.Print "Code took " & sw.ElapsedMilliseconds " ms"
You might also consider using a different approach. Try calling your routines from a loop with enough iterations to give you a measurable time difference.
You can use two Win32 APIs:
QueryPerformanceCounter: To get the count at the start and end of the event.
QueryPerformanceFrequency: To get the number of ticks per second.
These use LARGE_INTEGER to represent 64 bit numbers.
There's code and an explanation in the MSDN KB article Q172338 How To Use QueryPerformanceCounter to Time Code
There's a Thomas Edison story, where he's interviewing some prospective engineers.
He asks them to determine the volume of a light bulb. Candidate A measures it and then uses the formula for the volume of a sphere, and another formula for the volume of the neck, and so on. Candidate B fills it with water and pours it into a measuring cup. Who do you think got the job?
Run it 1000 times and look at your watch before and after. Seconds = milliseconds.
I always use this in a module somewhere (could be in a class though). This code allows you to maintain up to six timers, with high accuracy:
Option Explicit
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private cFrequency As Currency
Private cCounters(0 To 5) As Currency
Public Sub StartCounter(Optional lCounterIndex As Long)
QueryPerformanceFrequency cFrequency
QueryPerformanceCounter cCounters(lCounterIndex)
End Sub
Public Function GetCounter(Optional lCounterIndex As Long) As Double
Dim cCount As Currency
QueryPerformanceFrequency cFrequency
QueryPerformanceCounter cCount
GetCounter = Format$((cCount - cCounters(lCounterIndex) - CCur(0.0008)) / cFrequency, "0.000000000")
End Function
Public Function Scientific(ByVal dValue As Double) As String
Dim lMultiplier As Long
Dim vNames As Variant
lMultiplier = 5
vNames = Array("peta", "tera", "giga", "mega", "kilo", "", "milli", "micro", "nano", "pico", "femto")
If Abs(dValue) < 1 Then
While Abs(dValue) < 1
dValue = dValue * 1000
lMultiplier = lMultiplier + 1
Wend
ElseIf Abs(dValue) >= 1000 Then
While Abs(dValue) >= 1000
dValue = dValue / 1000
lMultiplier = lMultiplier - 1
Wend
End If
Scientific = Format$(dValue, "0.000") & " " & vNames(lMultiplier)
End Function
You can try using the System::Diagnostics::Stopwatch
Imports System.Diagnostics
Dim sw As New Stopwatch()
sw.Start()
// do something
LOG("Elapsed " + sw.ElapsedMilliseconds + " ms")