by BigCalm (10 Submissions)
Category: Miscellaneous
Compatability: Visual Basic 3.0
Difficulty: Intermediate
Date Added: Wed 3rd February 2021
Rating: 
(3 Votes)
By using the "Performance Timer" in all modern PC's it is possible to achieve timing accuracy of greater than one microsecond (yes, 1 millionth of a second). This code shows you how to use API calls to access and use it.
API Declarations' Unsigned 64-bit long
Public Type LongLong
LowPart As Long
HighPart As Long
End Type
Declare Function QueryPerformanceCounter Lib "kernel32" _
(lpPerformanceCount As LongLong) As Long
Declare Function QueryPerformanceFrequency Lib "kernel32" _
(lpFrequency As LongLong) As Long
Declare Function timeGetTime Lib "winmm.dll" () As Long
VBcoders' Unsigned 64-bit long
Public Type LongLong
LowPart As Long
HighPart As Long
End Type
Declare Function QueryPerformanceCounter Lib "kernel32" _
(lpPerformanceCount As LongLong) As Long
Declare Function QueryPerformanceFrequency Lib "kernel32" _
(lpFrequency As LongLong) As Long
Declare Function timeGetTime Lib "winmm.dll" () As Long
Public Function TimerElapsed(Optional µS As Long = 0) As Boolean
Static StartTime As Variant ' Decimal
Static PerformanceFrequency As LongLong
Static EndTime As Variant ' Decimal
Dim CurrentTime As LongLong
Dim Dec As Variant
If µS > 0 Then
' Initialize
If QueryPerformanceFrequency(PerformanceFrequency) Then
' Performance Timer available
Debug.Print PerformanceFrequency.HighPart & " " & PerformanceFrequency.LowPart
If QueryPerformanceCounter(CurrentTime) Then
Else
' Performance timer is available, but is not responding
CurrentTime.HighPart = 0
CurrentTime.LowPart = timeGetTime
PerformanceFrequency.HighPart = 0
PerformanceFrequency.LowPart = 1000
End If
Else
' Performance timer is not available.
CurrentTime.HighPart = 0
CurrentTime.LowPart = timeGetTime
PerformanceFrequency.HighPart = 0
PerformanceFrequency.LowPart = 1000
End If
' Work out start time...
' Convert to DECIMAL
Dec = CDec(CurrentTime.LowPart)
' make this UNSIGNED
If Dec < 0 Then
Dec = CDec(Dec + (2147483648# * 2))
End If
' Add higher value
StartTime = CDec(Dec + (CurrentTime.HighPart * 2147483648# * 2))
' Put performance frequency into Dec variable
Dec = CDec(PerformanceFrequency.LowPart)
' Convert to unsigned
If Dec < 0 Then
Dec = CDec(Dec + (2147483648# * 2))
End If
' Add higher value
Dec = CDec(Dec + (PerformanceFrequency.HighPart * 2147483648# * 2))
' Work out end time from this
EndTime = CDec(StartTime + µS * Dec / 1000000)
TimerElapsed = False
Else
If PerformanceFrequency.LowPart = 1000 And PerformanceFrequency.HighPart = 0 Then
' Using standard windows timer
Dec = CDec(timeGetTime)
If Dec < 0 Then
Dec = CDec(Dec + (2147483648# * 2))
End If
If Dec > EndTime Then
TimerElapsed = True
Else
TimerElapsed = False
End If
Else
If QueryPerformanceCounter(CurrentTime) Then
Dec = CDec(CurrentTime.LowPart)
' make this UNSIGNED
If Dec < 0 Then
Dec = CDec(Dec + (2147483648# * 2))
End If
Dec = CDec(Dec + (CurrentTime.HighPart * 2147483648# * 2))
If Dec > EndTime Then
TimerElapsed = True
Else
TimerElapsed = False
End If
Else
' Should never happen in theory
Err.Raise vbObjectError + 2, "Timer Elapsed", "Your performance timer has stopped functioning!!!"
TimerElapsed = True
End If
End If
End If
End Function
' Example use
Public Sub DummySub()
Dim i As Long
' count for 5 seconds and then display result
TimerElapsed (5000000)
i = 0
Do While TimerElapsed = False
i = i + 1
DoEvents
Loop
MsgBox i
End Sub