Attribute VB_Name = "modHighResTimer"
'*******************************************************************************
' MODULE:       modHighResTimer
' FILENAME:     modHighResTimer.bas
' AUTHOR:       Jared De Blander
' CREATED:      September 18, 2003
' COPYRIGHT:    Copyright (c) 2003-2006 Jared De Blander. All Rights Reserved.
' WEBSITE:      http://www.jx90.com/
' E-MAIL:       jared@deblander.org
'
'LICENSE:
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
'
' DESCRIPTION:
' This module is designed to be an easy to drop in replacement for the standard
' timer function. Simply call getTimer for a much more accurate timing value
' than is normally available. You can simply rename getTimer to Timer as well
' and it will update all your timer calls. If you prefer a value expressed in a
' different resolution such as milliseconds simply call the corresponding
' function, getTimerMS in that case. All the API calls and checks are handled
' for you. Maximum resolution is now machine dependant. On an AMD Athlon XP
' 2000+ 1.3 microseconds is common. A Pentium 4 3.0GHz averages 0.43
' microseconds. Sample test routine:
'
'Private Sub Form_Load()
'    Dim r As Double
'    Dim s As Double
'    'initialize variables and getTimer
'    r = getTimer
'    s = getTimer
'
'    'fetch calls actual calls for performance
'    r = getTimer
'    s = getTimer
'    MsgBox s - r
'End Sub
'
'MODIFICATION HISTORY:
'4/6/2006
'1. Added getTimerWaitMS for easy and accurate pausing at millisecond levels
'   in a single call with optional use of DoEvents during the puase.
'
'3/10/2006
'1.Corrections to revision history. Expanded details on 7/4/2004.
'
'12/6/2005
'1. Comment fix in getTimerMicroS
'
'8/16/2005
'1.Added getTimeMicroS that returns a microsecond formatted time.
'2.Added getTimerNS that returns a nanosecond formatted time. Only useable on
'  some new machines. Test on XP 64 3000+
'3.Updated method getTimerMS and NS are called to prevent overflows and fetch
'  more predictable and accurate results.
'
'4/18/2005
'1.Fixed negative after ~25 days with getTickCount API
'2.Added comments
'3.per:
'   http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winui
'   /winui/windowsuserinterface/windowing/timers/timerreference/timerfunctions
'   /queryperformancefrequency.asp
'  QPF is only called once to increase performance of the high resolution timing
'4.Added getTimerMs that returns a millisecond formatted time.
'
'4/13/2005
'1.Complete rewrite due to a bug discovered that related to the newer Pentium 4
'
'7/20/2004
'1.Switched to GetTickCount for backup method instead of the Multimedia Timer.
'  Repeated calls to multimedia timer caused nView to hang. Informed nVidia and
'  have received no response as of 5/7/2006.
'
'3/5/2004
'1.Added QueryPerformanceCounter method as main method. Old style as backup
'  for machines that don't support QueryPerformanceCounter
'
'9/18/2003
'1.Initial release. ~1ms accuracy
'
'*******************************************************************************

Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long        '<1 ms - ultra high resolution system clock
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long             'frequency divisor to get seconds from the counter
Private Declare Function GetTickCount Lib "kernel32" () As Long                                                 '1 ms resolution CPU clock

Private QPC_Checked     As Boolean      'whether or not we have checked the QPC on this processor
Private QPC_Works       As Boolean      'whether or not the QPC works on this processor

Private QPF             As Currency     'store the frequency divider
Private QPC             As Currency     'store the counter
Private tickCount       As Long         'store the tick count

Public Function getTimer() As Double                        'return number of seconds
    If QPC_Checked Then                                     'if we have checked QPC on this processor
        If QPC_Works Then                                   'and the QPC works
            QueryPerformanceCounter QPC                     'grab the counter
            getTimer = QPC / QPF                            'calculate the result
        Else                                                'otherwise we must use the 1 ms clock
            getTimer = CDbl(((GetTickCount And &HFFFFFFFE) _
                \ 2) And &H7FFFFFFF) / CDbl(500)            ' right shift one place, removing the sign bit and adjust to seconds
        End If
    Else                                                    'if we haven't checked
        QPC_Checked = True                                  'note that we are checking the QPC now
        QueryPerformanceFrequency QPF                       'store the frequency divider in QPF
        If QPF <> 0 Then                                    'if QPF is not 0 this chip supports QPC
            QPC_Works = True                                'record that QPC works
            QueryPerformanceCounter QPC                     'store the counter in QPC
            getTimer = QPC / QPF                            'calculate the result
        Else                                                'otherwise if QPF is 0 we must use the 1 ms clock
            QPC_Works = False                               'record that QPC did NOT work
            getTimer = CDbl(((GetTickCount And &HFFFFFFFE) _
                \ 2) And &H7FFFFFFF) / CDbl(500)            ' right shift one place, removing the sign bit and adjust to seconds
        End If
    End If                                                  'return back to program
End Function

Public Function getTimerMS() As Double                      'return the number of milliseconds
    getTimerMS = getTimer                                   'fetch timer value
    getTimerMS = getTimerMS * CDbl(1000)                    'multiply seconds passed * 1,000
End Function                                                'return back to program

Public Function getTimerMicroS() As Double                  'return the number of microseconds
    getTimerMicroS = getTimer                               'fetch timer value
    getTimerMicroS = getTimerMicroS * CDbl(1000000)         'multiply seconds passed * 1,000,000
End Function                                                'return back to program

Public Function getTimerNS() As Double                      'return the number of nanoseconds
    getTimerNS = getTimer                                   'fetch timer value
    getTimerNS = getTimerNS * CDbl(1000000000)              'multiply seconds passed * 1,000,000,000
End Function                                                'return back to program

Public Sub getTimerWaitMS(theTimeToWait As Double, Optional UseDoEvents As Boolean = False)
    Static startTime As Double                              'static so we don't have to reclaim the memory each time this is called
    startTime = getTimerMS
    If UseDoEvents Then

        Do While getTimerMS - startTime < theTimeToWait
            'sit around burning up cpu cycles
            DoEvents
        Loop
    Else
        Do While getTimerMS - startTime < theTimeToWait
            'sit around burning up cpu cycles
        Loop
    End If
End Sub