Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0746: QueryPerformance und StopWatch mit Variablentyp Currency

 von 

Beschreibung 

Tipp 11 demonstriert die Verwendung der API-Funktion QueryPerformaceCounter, bzw. -Frequency. Der vorliegende Tipp soll kein Ersatz für Tipp 11 sein, sondern aufzeigen, dass es unter VB6 nicht erforderlich ist, einen selbstdefinierten Datentyp wie LONG_INTEGER zu verwenden. Der Datentyp Currency ist geradezu ideal für die Verwendung mit der Funktion QueryPerformanceCounter und/oder QueryPerformanceFrequency:

Der Datentyp Currency in VB6 ist ein 64Bit-Datentyp mit einem Festpunktanteil. Beim Bitwert &H2710 (bzw decimal 10000) ist der Wert 1 definiert. Der kleinste positive Wert des Datentyps Currency ist 0.0001. Da die Einheit Ticks ebenfalls den Parameter 10000 beinhaltet, ist der VB-Datentyp Currency genau der richtige Datentyp für Zeitmessungen mit der QueryPerformance-API.

Schwierigkeitsgrad:

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

QueryPerformanceCounter, QueryPerformanceFrequency, RtlMoveMemory

Download:

Download des Beispielprojektes [4,26 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "BtnReset"
' Steuerelement: Schaltfläche "BtnStop"
' Steuerelement: Schaltfläche "BtnStart"
Option Explicit
'hier nur ein TestTreiber für die Stopp-Uhr-Klasse StopWatch
Private mSW As StopWatch

Private Sub Form_Load()
    Set mSW = New StopWatch
End Sub

Private Sub BtnStart_Click()
    Call mSW.Start
End Sub

Private Sub BtnStop_Click()
    Call mSW.SStop
    Dim s As String
    s = s & "StopWatch.Frequency    : " & StopWatch.Frequency & vbCrLf
    s = s & "Stopwatch.GetTimestamp : " & StopWatch.GetTimestamp & vbCrLf
    s = s & "mSW.ElapsedTicks       : " & mSW.ElapsedTicks & vbCrLf
    s = s & "mSW.ElapsedMilliseconds: " & mSW.ElapsedMilliseconds & vbCrLf
    s = s & "mSW.Elapsed            : " & mSW.ElapsedToString & vbCrLf
    MsgBox (s)
End Sub

Private Sub BtnReset_Click()
    Call mSW.Reset
    MsgBox "StoppUhr zurückgesetzt! " & CStr(mSW.ElapsedMilliseconds) & " ms"
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------ Anfang Klasse "StopWatch" alias StopWatch.cls  ------
Option Explicit
'Class StopWatch

'Der Datentyp Currency in VB ist ein 64Bit-Datentyp mit einem
'Festpunktanteil. D.h. beim Bitwert &H2710 (bzw decimal 10000)
'ist der Wert 1 definiert, bzw. der kleinste positive Wert des
'Datentyps Currency ist 0.0001

'Da die Einheit Ticks ebenfalls den Parameter 10000 beinhaltet,
'ist der VB-Datentyp Currency genau der richtige Datentyp für
'Zeitmessungen mit der QueryPerformance-API

Private mFrequency        As Currency
Private mIsHighResolution As Boolean
Private mIsRunning        As Boolean
Private mStartTimeStamp   As Currency
Private mElapsed          As Currency
Private mTickFrequency    As Double

'In der gleihnamigen VB.Net-Klasse wird hier der Datentyp Long,
'bzw Int64 verwendet.
'Der Korrekturfaktor für den Datentyp Currency

Private Const CurCorrect          As Long = 10000
Private Const TicksPerMillisecond As Long = 10000 / CurCorrect    '&H2710
Private Const TicksPerSecond      As Long = 10000000 / CurCorrect '&H989680

Private Declare Function QueryPerformanceCounter Lib "kernel32" ( _
    ByRef lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" ( _
    ByRef lpFrequency As Currency) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" ( _
    ByRef pDst As Any, ByRef pSrc As Any, ByVal bytLength As Long)
    
Private Sub Class_Initialize()
    If Not (QueryPerformanceFrequency(mFrequency) = 1) Then
        mIsHighResolution = False
        mFrequency = TicksPerSecond
        mTickFrequency = 1
    Else
        mIsHighResolution = True
        mTickFrequency = (TicksPerSecond / CDbl(mFrequency))
    End If
End Sub

'Public Function GetTimestamp() As Currency 'Long 'LongInt
Public Function GetTimestamp() As Currency
    GetTimestamp = pGetTimestamp * CurCorrect
End Function

Private Function pGetTimestamp() As Currency
    If mIsHighResolution Then
        Call QueryPerformanceCounter(pGetTimestamp)
    Else
        pGetTimestamp = DateTime.Now
    End If
End Function

Public Sub Start()
    If Not mIsRunning Then
        mStartTimeStamp = pGetTimestamp
        mIsRunning = True
    End If
End Sub

Public Function StartNew() As StopWatch
    Set StartNew = New StopWatch
    Call StartNew.Start
End Function

Public Sub SStop()
    If IsRunning Then
        Dim c As Currency: c = (pGetTimestamp - mStartTimeStamp)
        mElapsed = (mElapsed + c)
        mIsRunning = False
    End If
End Sub

Public Sub Reset()
    mElapsed = 0
    mIsRunning = False
    mStartTimeStamp = 0
End Sub


'Shared-Member Properties
Public Property Get Frequency() As Currency
    'Diese Multiplikation mit CurCorrect ist nur dazu da, die Klasse
    'nach außen hin konsistent zu halten mit der gleichnamigen Klasse
    'aus dem .NETFX
    Frequency = mFrequency * CurCorrect
End Property
Public Property Get IsHighResolution() As Boolean
    IsHighResolution = mIsHighResolution
End Property

' #################### '   Public Properties   ' #################### '
Public Property Get ElapsedToString() As String 'TimeSpan
    ElapsedToString = TimeSpanToString(GetElapsedDateTimeTicks)
End Property

Private Function TimeSpanToString(ByVal ticks As Currency) As String
    Dim b As String
    Dim h As Long, m As Long, s As Long, n As Long
    Dim days As Long:  days = CInt((ticks / 86400000))
    Dim time As Currency: time = (ticks Mod 86400000)
    
    If (ticks < 0) Then
        b = b & "-"
        days = -days
        time = -time
    End If
    
    If (days <> 0) Then
        b = b & CStr(days) & "."
    End If
    
    'Stunden
    h = CInt(((time \ 3600000) Mod 24))
    b = b & IntToString(h, 2) & ":"
    
    'Minuten
    m = CInt(((time \ 60000) Mod 60))
    b = b & IntToString(m, 2) & ":"
    
    'Sekunden
    s = CInt(((time \ 1000) Mod 60))
    b = b & IntToString(s, 2)
    
    n = (ticks - (CCur(h) * CCur(3600000)) _
               - (CCur(m) * CCur(60000)) _
               - (CCur(s) * CCur(1000))) * 10000
               
    If (n <> 0) Then
        b = b & "."
        b = b & IntToString(n, 7)
    End If
    TimeSpanToString = b
End Function

Private Function IntToString(ByVal n As Long, ByVal digits As Long) As String
    Dim l As Long
    IntToString = CStr(n)
    l = Len(IntToString)
    If l < digits Then IntToString = String$(digits - l, "0") & IntToString
End Function

Public Property Get ElapsedMilliseconds() As Currency 'Long 'LongInt
    ElapsedMilliseconds = GetElapsedDateTimeTicks / TicksPerMillisecond
End Property

Public Property Get ElapsedTicks() As Currency 'As Long 'LongInt
    ElapsedTicks = GetRawElapsedTicks * CurCorrect
End Property

Public Property Get IsRunning() As Boolean
    IsRunning = mIsRunning
End Property

' #################### '   Private Functions   ' #################### '
Private Function GetElapsedDateTimeTicks() As Currency
    Dim rawElapsedTicks As Currency: rawElapsedTicks = GetRawElapsedTicks
    If mIsHighResolution Then
        Dim d As Double: d = CDbl(rawElapsedTicks)
        d = (d * mTickFrequency)
        GetElapsedDateTimeTicks = CCur(d)
    Else
        GetElapsedDateTimeTicks = rawElapsedTicks
    End If
End Function

Private Function GetRawElapsedTicks() As Currency
    Dim Elapsed As Currency: Elapsed = mElapsed
    If mIsRunning Then
        Dim c As Currency: c = (GetTimestamp - mStartTimeStamp)
        Elapsed = (Elapsed + c)
    End If
    GetRawElapsedTicks = Elapsed
End Function
'------- Ende Klasse "StopWatch" alias StopWatch.cls  -------
'------- Anfang Modul "ModSystem" alias ModSystem.bas -------
Option Explicit
Public StopWatch As New StopWatch

'-------- Ende Modul "ModSystem" alias ModSystem.bas --------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.