'--------------------------------------------------
' Klasse für Zeitmessungen
'--------------------------------------------------
Option Explicit
' API Deklarationen
Private Declare Function QueryPerformanceCounter Lib "kernel32" _
  (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" _
  (lpFrequency As LARGE_INTEGER) As Long
'--------------------------------------------------
' C Type
Private Type LARGE_INTEGER
  lowpart   As Long
  highpart  As Long
End Type
'--------------------------------------------------
Private mdTime                  As Double
Private mdAverage               As Double
Private mlCounter               As Long
'--------------------------------------------------
Private mdFrequence             As Double
Private mLIStart                As LARGE_INTEGER
Private mLIStop                 As LARGE_INTEGER
 
Private mbIsTimerOK             As Boolean
Private mbRunning               As Boolean
'--------------------------------------------------
' Known errors + 513
Private Const ErrS As Long = 20900
' + 1 - "BSTimer.Initialize", "PerformanceCounter not supported!"
' + 2 - "BSTimer.StopTimer", "Timer not started!"
' + 3 - "BSTimer.StopTimer", "Timer still running!"
'--------------------------------------------------
 
Private Sub Class_Initialize()
  '--------------------------------------------------
  'Prüfen ob Timer unterstützt wird
  If QueryPerformanceFrequency(mLIStart) Then
    mbIsTimerOK = True
    mbRunning = False
    'TimerFrequenz
    mdFrequence = LIToCurr(mLIStart)
  Else
    Err.Raise (ErrS + 1), "BSTimer.Initialize", _
      "PerformanceCounter not supported!"
  End If
  '--------------------------------------------------
End Sub
 
Public Property Get IsTimerOK() As Boolean
  ' Gibt zurück ob der PT von der Hardware unterstütz wird
  IsTimerOK = mbIsTimerOK
End Property
 
Public Property Get IsRunning() As Boolean
  IsRunning = mbRunning
End Property
 
Public Property Get Counter() As Long
  Counter = mlCounter
End Property
 
Public Function ReachedTime() As String
  '--------------------------------------------------
  ' Liefert die im letzten Durchlauf verstrichene Zeit
  Static i          As Long
  Dim cStart        As Currency
  Dim cStop         As Currency
  '--------------------------------------------------
  cStart = LIToCurr(mLIStart)
  cStop = LIToCurr(mLIStop)
  '--------------------------------------------------
  If (cStop - cStart) < mdFrequence Then Exit Function
  ReachedTime = ((cStop - cStart) / mdFrequence)
  '--------------------------------------------------
  mdTime = mdTime + Format(ReachedTime, "##0.000000000")
  i = i + 1
  mlCounter = i
  '--------------------------------------------------
End Function
 
Public Sub StopTimer()
  ' Timer stoppen
  Call QueryPerformanceCounter(mLIStop)
  If Not mbRunning Then Err.Raise (ErrS + 2), _
    "BSTimer.StopTimer", "Timer not started!"
  mbRunning = False
End Sub
 
Public Sub StartTimer()
  ' Timer starten
  If mbRunning Then
    Err.Raise (ErrS + 3), "BSTimer.StopTimer", _
      "Timer still running!"
  End If
  mbRunning = True
  Call QueryPerformanceCounter(mLIStart)
End Sub
 
Public Property Get Average() As Double
  '--------------------------------------------------
  ' liefert die Durchschnittszeit aller durchgeführten Läufe
  mdAverage = mdTime / mlCounter
  Average = mdAverage
  '--------------------------------------------------
End Property
 
Public Property Get Laufzeit() As Double
  '--------------------------------------------------
  ' Liefert die Gesamtlaufzeit
  Laufzeit = mdTime
  '--------------------------------------------------
End Property
 
Private Function LIToCurr(LargeInt As LARGE_INTEGER) As Currency
  '--------------------------------------------------
  ' Umwandeln von LARGE_INTEGER in Currency
  With LargeInt
    If .lowpart > 0 Then
      LIToCurr = .lowpart
    Else
      LIToCurr = CCur(2 ^ 31) + CCur(.lowpart And &H7FFFFFFF)
    End If
    LIToCurr = LIToCurr + .highpart * CCur(2 ^ 32)
  End With
  '--------------------------------------------------
End Function

  Dim oTimer  As BSTimer
 
  Set oTimer = New BSTimer
  oTimer.StartTimer
    Call MachIrgendWas
  oTimer.StopTimer
  MsgBox oTimer.ReachedTime
  Set oTimer = Nothing