Planet Source Code Jumbo …e CD Visual Basic 1 to 7/3_2004-2005.ISO/Data/Zips/BAS_Module18049510142004.psc/ModuleMania/APITimer.bas

BASIC Source File | 2004-04-28 | 5.7 KB | 111 lines

Attribute VB_Name = "APITimer"
Option Explicit                                              '-⌐Rd-

' =====================================================================
' WARNING!!! Code-only timers are inherently dangerous in the VB IDE,
' because the system blindly calls back into your code until the timer
' is turned off with an API KillTimer call.
' =====================================================================

' System Timer API's
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapseMilliseconds As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

' Performance Counter API's
Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

Private mCurFreq As Currency

' =====================================================================
' Simple (imprecise) Timer - BeginTimer, EndTimer and TimerProc
' =====================================================================
'
' BeginTimer creates a new timer, and returns the new timer's ID.
' This function returns zero on failure; no error is raised.
'
' After the specified time has elapsed, the system calls the TimerProc
' sub-routine. You must add code to TimerProc to handle this event.
'
' Each running timer calls the same TimerProc sub-routine, and so
' each TimerProc event is identified by the idEvent parameter which
' matches the ID returned by BeginTimer.
'
' You shouldnÆt rely on the timer to be extremely accurate, as youÆre
' subject to the unpredictability of Win32 thread scheduling.
'
' Remember - do not End or enter Debug mode while a timer is running!
' =====================================================================
Public Function BeginTimer(ByVal lMilliseconds As Long) As Long
Attribute BeginTimer.VB_Description = "BeginTimer creates a new timer, and returns the new timer's ID. This function returns zero on failure; no error is raised."
    BeginTimer = SetTimer(0&, 0&, lMilliseconds, AddressOf TimerProc)
End Function

' =====================================================================
' EndTimer terminates the specified timer created by BeginTimer.
' The TimerID is passed ByRef and is reset to zero on success.
'
' This function returns True on success, or False otherwise.
' =====================================================================
Public Function EndTimer(ByRef TimerID As Long) As Boolean
Attribute EndTimer.VB_Description = "EndTimer terminates the specified timer created by BeginTimer. The TimerID is passed ByRef and is reset to zero on success."
    If (TimerID) Then EndTimer = KillTimer(0&, TimerID)
    If EndTimer Then TimerID = 0 ' Reset TimerID
End Function

' =====================================================================
' After the specified time has elapsed, the system calls the TimerProc
' sub-routine. You must add code to TimerProc to handle this event.
'
' Each running timer calls this same TimerProc sub-routine, and so
' each TimerProc event is identified by the idEvent parameter which
' matches the ID returned by BeginTimer.
' =====================================================================
Private Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
'    Static fInTimerProc As Boolean
'    If fInTimerProc Then Exit Sub
'    fInTimerProc = True


' hWnd    - Handle of CWnd that called SetTimer (0&)
' uMsg    - WM_TIMER = &H113
' idEvent - Timer identification (returned by BeginTimer)
' dwTime  - System time
Debug.Print "The timer with ID " & idEvent & " just fired. System time is " & dwTime


'    fInTimerProc = False
End Sub

' ========================================================================
' Precise Timer - ProfileStart and ProfileStop
' ========================================================================
'
' ProfileStart returns the current value of the high-resolution performance
' counter as a Currency data type. You pass this value to ProfileStop which
' subtracts it from an ending count and returns the difference (elapsed time).
'
' The result comes out nicely as a fixed-point Currency number representing
' seconds accurate to four decimal places. In the case of no high-resolution
' timer, these functions return zero.
'
' Multiply by 1000 to convert to milliseconds (or 1000000 for microseconds).
'
' Note - these functions return values too accurate to fit in a Long.
' ========================================================================
Public Function ProfileStart() As Currency
Attribute ProfileStart.VB_Description = "ProfileStart returns the current value of the high-resolution performance counter as a Currency data type. You pass this value to ProfileStop which subtracts it from an ending count and returns the difference."
    If mCurFreq = 0 Then QueryPerformanceFrequency mCurFreq
    If (mCurFreq <> 0) Then QueryPerformanceCounter ProfileStart
End Function

Public Function ProfileStop(ByVal curStart As Currency) As Currency
Attribute ProfileStop.VB_Description = "ProfileStart returns the current value of the high-resolution performance counter as a Currency data type. You pass this value to ProfileStop which subtracts it from an ending count and returns the difference."
    If (mCurFreq <> 0) Then
        Dim curStop As Currency
        QueryPerformanceCounter curStop
        ProfileStop = (curStop - curStart) / mCurFreq
    End If
End Function
'                                                                    :¢)