PerformanceCounter/Form1.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3090
   ClientLeft      =   60
   ClientTop       =   435
   ClientWidth     =   4650
   LinkTopic       =   "Form1"
   ScaleHeight     =   3090
   ScaleWidth      =   4650
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command1
      Caption         =   "Delay MsgBox by 3000000 µs"
      Height          =   3075
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   4635
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2003, 2004 by Louis. Demonstrates the use of QueryPerformanceCounter in VB. Request by a blackbeltvb
'member. Further information gained from http://www.rookscape.com/vbgaming/tutBL.php.
'
'Downloaded from www.louis‑coder.com.
'Demonstrates how to access modern CPUs' high performance counter feature.
'
'Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long 'oringinal
'Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long'original
'
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long 'VB specific
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long 'VB specific
'
Private Declare Sub STUFF_COPYMEMORY Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long) 'for debugging
'
Private Type LARGE_INTEGER 'original, debug
    lowpart As Long
    highpart As Long
End Type

Private Sub Command1_Click()
    '
    'DEBUG (shows that VB Currency var can be used instead of the Windows LARGE_INTEGER‑structure)
    Dim c As Currency
    Dim l As LARGE_INTEGER
    '
    l.highpart = 0
    l.lowpart = 2003
    '
    Call STUFF_COPYMEMORY(c, l, 8)
    '
    Debug.Print c 'original number / 1000
    'END Of DEBUG
    '
    Debug.Print "Begun at " + Time$
    Call Delayus(3000000)
    Debug.Print "Finished at " + Time$
    MsgBox "Yeah", vbOKOnly + vbInformation
End Sub

Private Sub Delayus(ByVal Microseconds As Double)
    'on error resume next 'waits for microseconds (note that the Windows scheduler may interrupt the waiting, so the waiting time is not so exact)
    Dim curFreq As Currency
    Dim curStart As Currency
    Dim curEnd As Currency
    Dim dblResult As Double
    Dim dblPassed As Double
    'begin
    QueryPerformanceFrequency curFreq 'get the timer frequency
    QueryPerformanceCounter curStart 'get the start time
    '
    Microseconds = Microseconds / 1000000#
    '
    Do While (dblPassed < Microseconds)
        QueryPerformanceCounter curEnd 'get the end time
        dblPassed = (curEnd ‑ curStart) / curFreq 'calculate the duration (in microseconds)
    Loop
    '
End Sub

'>>>ORIGINAL CODE>>>

'original Pascal (?) code:
'procedure delayus(I : Int64);  Short 100us delay
'
'> > > >Var tic,t,F,s : Int64;
'> > > >begin
'> > > > S:=0;
'> > > > if I<>0 then
'> > > > begin
'> > > >   QueryPerformanceFrequency(F);
'> > > >   QueryPerformanceCounter(tic);
'> > > >   while (S<I) do    {100 usec}
'> > > >   begin
'> > > >     QueryPerformanceCounter(t);
'> > > >     s:=(t‑tic) * 1000000 DIV F ; {F in usec}
'> > > >   end;
'> > > > end;
'> > > >end;

'<<<END OF ORIGINAL CODE<<<

'>>>NEWBIE'S TRY>>>

'NOTE: the following code is an attempt to use the LARGE_INTEGER structure, coded
'before knowing the trick with the VB currency var. The following code does not work.

'Private Sub Delayus(ByVal i As Long)
'    'on error resume next
'    Dim tic As LARGE_INTEGER
'    Dim t As LARGE_INTEGER
'    Dim F As LARGE_INTEGER
'    Dim s As LARGE_INTEGER
'
'    s.highpart = 0
'    s.lowpart = 0
'
'    If (i) Then
'        Call QueryPerformanceFrequency(F)
'        Debug.Print F.highpart
'        Debug.Print F.lowpart
'        Debug.Print LARGE_INTEGER_ToCurrency(F)
'        Call QueryPerformanceCounter(tic)
'        Debug.Print tic.highpart
'        Debug.Print tic.lowpart
'        Debug.Print LARGE_INTEGER_ToCurrency(tic)
'        Do While (s.lowpart < i)
'            Call QueryPerformanceCounter(t)
'            s.lowpart = STUFF_DIV(CurrencyToLong((LARGE_INTEGER_ToCurrency(t) ‑ LARGE_INTEGER_ToCurrency(tic)) * 10000000@), F.lowpart)
'            Debug.Print s.lowpart
'        Loop
'    End If
'
'End Sub
'
'Private Function LARGE_INTEGER_ToCurrency(ByRef LargeIntegerVar As LARGE_INTEGER) As Currency
'    'on error resume next
'    LARGE_INTEGER_ToCurrency = CCur(LargeIntegerVar.highpart) * (2@ ^ 31@ ‑ 1@) + SignedLongToUnsignedCurrency(LargeIntegerVar.lowpart)
'End Function
'
'Private Function SignedLongToUnsignedCurrency(ByVal LongNumber As Long) As Currency
'    'on error resume next
'    If LongNumber < 0 Then
'        SignedLongToUnsignedCurrency = 2147483648@ + CCur(LongNumber And 2147483647)
'    Else
'        SignedLongToUnsignedCurrency = CCur(LongNumber)
'    End If
'End Function
'
'Private Function CurrencyToLong(ByVal CurrencyNumber As Currency) As Long
'    'on error resume next
'    If CurrencyNumber > 2147483647@ Then
'        CurrencyToLong = 2147483647
'    Else
'        CurrencyToLong = CLng(CurrencyNumber)
'    End If
'End Function
'
'Private Function STUFF_DIV(ByVal Value As Long, ByVal Divisor As Long) As Long
'    'on error resume next 'how often one number 'goes into' an other
'    STUFF_DIV = (Value ‑ (Value Mod Divisor)) \ Divisor
'End Function

'<<<END OF NEWBIE'S TRY<<<


[END OF FILE]