تايمر سريع - نسخة قابلة للطباعة

كود :
' في قسم التصريحات العام



Private Type LARGE_INTEGER

    lowpart As Long

    highpart As Long

End Type



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 ContinueTimer As Boolean    ' لتشغيل أو إيقاف المؤقت



' ==================================



Private Function LargeIntToDbl(LoPart As Long, HiPart As Long) As Double

    'This function converts the LARGE_INTEGER data type to a double

    Dim dblLo As Double, dblHi As Double

    

    If LoPart < 0 Then

        dblLo = 2 ^ 32 + LoPart

    Else

        dblLo = LoPart

    End If

    

    If HiPart < 0 Then

        dblHi = 2 ^ 32 + HiPart

    Else

        dblHi = HiPart

    End If

    

    LargeIntToDbl = dblLo + dblHi * 2 ^ 32

End Function



' إجراء المؤقت

Private Sub TimerProcedure()

    Dim LIValue As LARGE_INTEGER

    

    Dim Frequency As Double

    Dim StartCount As Double

    Dim EndCount As Double

    

    ' QueryPerformanceFrequency gives the frequency as Counts per Second:

    If QueryPerformanceFrequency(LIValue) = 0 Then

        MsgBox "النظام لا يدعم المؤقتات ذات الدقة العالية"

        Exit Sub

    Else

        Frequency = LargeIntToDbl(LIValue.lowpart, LIValue.highpart)

    End If

    

    Do While ContinueTimer

        ' QueryPerformanceCounter gives the current Counter value:

        QueryPerformanceCounter LIValue

        StartCount = LargeIntToDbl(LIValue.lowpart, LIValue.highpart)



        ' الرقم 0.0001 الموجود في نهاية الحلقة التالية يعني جزء من عشرة آلاف من الثانية. أي أن القيمة بالثواني

        Do

            QueryPerformanceCounter LIValue

            EndCount = LargeIntToDbl(LIValue.lowpart, LIValue.highpart)

        Loop While ((EndCount - StartCount) / Frequency) < 0.0001



        ' بعد هذا السطر ضع الكود الذي تريد تنفيذه بعد المدة المحددة

        ' ... هنا

        ' ... هنا

                ' ... إلخ



        DoEvents    ' مهمة جداً جداً

    Loop

End Sub



' زر تشغيل المؤقت

Private Sub cmdRunTimer_Click()

    ContinueTimer = True

    TimerProcedure

End Sub



' زر إيقاف المؤقت

Private Sub cmdStopTimer_Click()

    ContinueTimer = False

End Sub



Private Sub Form_Unload(Cancel As Integer)

    ContinueTimer = False   ' مهمة جداً جداً

End Sub