home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Particle_E2115926102008.psc / ParticlesPSC / cTimLNG.cls < prev    next >
Text File  |  2006-02-25  |  4KB  |  140 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CTiming"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. ' CTiming - (c) 2004 by Donald Lessau, www.xbeat.net
  15. ' total rewrite of old CTimingPC
  16. ' created: 20040614
  17. ' updated: 20040914, 20050826
  18.  
  19. ' usage:
  20. ' Module declare: Private tmr as CTiming
  21. ' Make Instance:  Set tmr = New CTiming
  22. ' start timer:    tmr.Reset
  23. ' stop/get time:  dTime = tmr.Elapsed   'returns Double millisec with microsec as fraction
  24. '                 sTime = tmr.sElapsed  'returns String millisec with microsec as fraction and " msec"
  25.  
  26. Option Explicit
  27.  
  28. ' LARGE_INTEGER is faster than Currency type
  29. ' Currency requires CPU to execute slow floating-point instructions
  30. Private Type LARGE_INTEGER
  31.   Lo As Long
  32.   Hi As Long
  33. End Type
  34.  
  35. Private Declare Function QueryPerformanceCounter Lib "kernel32" ( _
  36.     lpPerformanceCount As LARGE_INTEGER) As Long
  37.  
  38. Private Declare Function QueryPerformanceFrequency Lib "kernel32" ( _
  39.     lpFrequency As LARGE_INTEGER) As Long
  40.  
  41. Private uFreq           As LARGE_INTEGER
  42. Private uStart          As LARGE_INTEGER
  43. Private uEnd            As LARGE_INTEGER
  44. Private uPauseStart     As LARGE_INTEGER
  45.  
  46. Private dPauseDuration  As Double
  47. Private dOverhead       As Double
  48.  
  49. Private fAvailable As Boolean
  50.  
  51. Private Sub Class_Initialize()
  52.   Const overheadLoopCount As Long = 100
  53.   Dim i As Long
  54.   
  55.   ' returns ticks/sec
  56.   If QueryPerformanceFrequency(uFreq) = 0& Then
  57.     
  58.     ' some CPUs do NOT support API QueryPerformanceCounter
  59.     MsgBox "Performance Counter not available", vbExclamation
  60.   
  61.   Else
  62.     
  63.     fAvailable = True
  64.     
  65.     ' determine API overhead
  66.     QueryPerformanceCounter uStart
  67.     For i = 1 To overheadLoopCount
  68.       QueryPerformanceCounter uEnd
  69.     Next
  70.     dOverhead = (LI2Dbl(uEnd) - LI2Dbl(uStart)) / overheadLoopCount
  71.     ' 20040614: AMD Athlon XP 2000+
  72.     ' frequency: 3579545          overhead: ca. 2,92 ticks
  73.     ''Debug.Print "frequency:"; LI2Dbl(uFreq), "overhead:"; dOverhead; "ticks"
  74.     
  75.   End If
  76.   
  77. End Sub
  78.  
  79. Friend Sub Reset()
  80.   dPauseDuration = 0
  81.   QueryPerformanceCounter uStart
  82. End Sub
  83.  
  84. Friend Function Elapsed() As Double
  85. ' return elapsed time in milliseconds
  86.   QueryPerformanceCounter uEnd
  87.   If fAvailable Then
  88.     Elapsed = 1000 * (LI2Dbl(uEnd) - LI2Dbl(uStart) - dOverhead - dPauseDuration) / LI2Dbl(uFreq)
  89.   End If
  90. End Function
  91.  
  92. Friend Function sElapsed() As String
  93. ' returns a nicely formatted string
  94.   sElapsed = Format$(Elapsed, "#,0.000") & " msec"
  95. End Function
  96.  
  97. Friend Sub PauseStart()
  98. ' begin pause
  99.   QueryPerformanceCounter uPauseStart
  100. End Sub
  101. Friend Sub PauseEnd()
  102. ' end pause: pause duration will be subtracted from elapsed time
  103.   QueryPerformanceCounter uEnd
  104.   ' add 2 * dOverhead: the API calls are part of the pause
  105.   dPauseDuration = dPauseDuration + (LI2Dbl(uEnd) - LI2Dbl(uPauseStart)) + 2 * dOverhead
  106. End Sub
  107.  
  108. Friend Sub Wait(dMsec As Double, Optional fDoEvents As Boolean)
  109. ' returns after dMsec milliseconds
  110. ' fDoEvents = False:  total suspend, all CPU blocked
  111.   Reset
  112.   Do
  113.     If fDoEvents Then
  114.       DoEvents
  115.     End If
  116.   Loop While fAvailable And Elapsed < dMsec
  117. End Sub
  118.  
  119. ' 20050826
  120. Private Function LI2Dbl(uLi As LARGE_INTEGER) As Double
  121.   Const OFFSET_4 As Double = 4294967296#  ' 2^32
  122.   Dim Low As Double, High As Double
  123.  
  124.   If uLi.Lo < 0 Then
  125.     Low = uLi.Lo + OFFSET_4
  126.   Else
  127.     Low = uLi.Lo
  128.   End If
  129.  
  130.   If uLi.Hi < 0 Then
  131.     High = uLi.Hi + OFFSET_4
  132.   Else
  133.     High = uLi.Hi
  134.   End If
  135.  
  136.   LI2Dbl = Low + High * OFFSET_4
  137.  
  138. End Function
  139.  
  140.