Millisekunden messen

Manch einer will Zeitdifferenzen im Millisekundenbereich messen. Meiner Ansicht nach wird einem dabei eine Genauigkeit vorgegaukelt, die in Wirklichkeit gar nicht erreicht werden kann. Das Betriebssystem Windows spielt da einfach nicht mit. Selbstverständlich gibt es API-Funktionen, die Zeiten im Millisekundenbereich liefern, besonders QueryPerformanceFrequency ist da ziemlich genau. Der Knackpunkt aber ist, in dem Moment zu messen, an dem gestoppt werden soll. Wer garantiert, dass gerade in diesem Moment die richtige Zeitscheibe aktiv ist?
Trotzdem hier ein paar Möglichkeiten, mit denen man Zeiten im Millisekundenbereich messen kann

Beispieldatei (Zeitmessung.zip 17 KB)

'##############################################
'#Zum Probieren zwei Buttons in ein Tabellenblatt
'# In das Klassenmodul des Tabellenblatts
'############################################## 

Private Sub cmbStart_Click()
Zeitmessung1 True
Zeitmessung2 True
Zeitmessung3 True
End Sub

Private Sub cmbStop_Click()
Dim message As String
message = "QueryPerformanceCounter : " _
    & CStr(Zeitmessung1(False)) & " s"
message = message & vbCrLf & "GetSystemTime : " _
    & CStr(Zeitmessung2(False))
message = message & vbCrLf & "GetTickCount : " _
    & CStr(Zeitmessung3(False)) & " ms"
MsgBox message
End Sub

'##############################################
'# In ein Modul
'############################################## 

Private Declare Function QueryPerformanceCounter _
    Lib "kernel32" (lpPerformanceCount As _
    LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency _
    Lib "kernel32" (lpFrequency As LARGE_INTEGER) _
    As Long

Private Type LARGE_INTEGER
    lowpart As Long
    highpart As Long
End Type

Private Sub Starten()
    Zeitmessung1 True
End Sub

Private Sub Stoppen()
    MsgBox CStr(Zeitmessung1(False)) & " s"
End Sub

Public Function Zeitmessung1(start As Boolean) As Double
Static udtBeginn As LARGE_INTEGER, udtEnde As LARGE_INTEGER
Dim udtQPF As LARGE_INTEGER, dblAuflösung As Double
    QueryPerformanceFrequency udtQPF
    dblAuflösung = udtQPF.highpart * (2 ^ 32) + udtQPF.lowpart
    If start Then
        QueryPerformanceCounter udtBeginn
    Else
        QueryPerformanceCounter udtEnde
        Zeitmessung1 = ((udtEnde.highpart * (2 ^ 32) + _
            udtEnde.lowpart) - (udtBeginn.highpart * (2 ^ 32) _
            + udtBeginn.lowpart)) / dblAuflösung
    End If
End Function

'##############################################
'# In ein Modul
'############################################## 

Private Declare Sub GetSystemTime Lib _
    "kernel32" (lpSystemTime As SYSTEMTIME)
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Sub Starten()
    Zeitmessung2 True
End Sub

Private Sub Stoppen()
    MsgBox Zeitmessung2(False)
End Sub

Public Function Zeitmessung2(start As Boolean) As String
Static Jetzt As SYSTEMTIME, beginn As SYSTEMTIME
Dim myBeginn As Date, myJetzt As Date
Dim myMilli As Double
If start Then
    GetSystemTime beginn
Else
    GetSystemTime Jetzt
    myBeginn = DateSerial(beginn.wYear, _
        beginn.wMonth, beginn.wDay)
    myBeginn = myBeginn + TimeSerial(beginn.wHour, _
        beginn.wMinute, beginn.wSecond)
    myJetzt = DateSerial(Jetzt.wYear, _
        Jetzt.wMonth, Jetzt.wDay)
    myJetzt = myJetzt + TimeSerial(Jetzt.wHour, _
        Jetzt.wMinute, Jetzt.wSecond)
    myJetzt = myJetzt - myBeginn
    If Jetzt.wMilliseconds >= beginn.wMilliseconds Then
        myMilli = Jetzt.wMilliseconds - beginn.wMilliseconds
    Else
        myMilli =Jetzt.wMilliseconds + 1000 - _
            beginn.wMilliseconds
        myJetzt = myJetzt - TimeSerial(0, 0, 1)
    End If
    Zeitmessung2 = myJetzt \ 1 & " Tage " & Format(myJetzt, _
        " hh:nn:ss:") & Format(myMilli, "000")
End If
End Function

'##############################################
'# In ein Modul
'############################################## 

Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Starten()
    Zeitmessung3 True
End Sub

Private Sub Stoppen()
    MsgBox CStr(Zeitmessung3(False)) & "  ms"
End Sub

Public Function Zeitmessung3(start As Boolean) As Long
Static beginn As Long
If start Then
    beginn = GetTickCount()
Else
    Zeitmessung3 = GetTickCount() - beginn
End If
End Function