14-05-13, 11:00 PM
السلام عليكم ورحمة الله وبركاتة
انا لقيت هذا الكود وانا بصفح مواضيع المنتتدى
وحاولت اني اشغله بس معرفتش ولو امكن
وضع هاذا الكود في مشروع
وجزاكم الله خيرا
' في قسم التصريحات العام
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
انا لقيت هذا الكود وانا بصفح مواضيع المنتتدى
وحاولت اني اشغله بس معرفتش ولو امكن
وضع هاذا الكود في مشروع
وجزاكم الله خيرا
' في قسم التصريحات العام
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