تعديل كود VBA ليعمل باقل من ثانية

[أبو ليمونه]

السلام عليكم

لدي كود يعمل كل ثانية

هل بالامكان ان اجعله يعمل كل نص ثانية (ملي بالثانية millisecond) ؟

Model

Sub ScheduleCopyPriceOver()

Application.Calculation = xlCalculationManual

TimeToRun = Now + TimeValue("00:00:01")

Application.OnTime TimeToRun, "CopyPriceOver"

Application.Calculation = xlCalculationAutomatic

End Sub

ThisWorkbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)

On Error Resume Next

Application.OnTime TimeToRun, "CopyPriceOver", , False

End Sub


Private Sub Workbook_Open()

DTime = Time

Call ScheduleCopyPriceOver

End Sub

تحياتي لكم

تم تعديل ديسمبر 4, 2012 بواسطه أبو ليمونه

[الـعيدروس]

السلام عليكم

Sub ScheduleCopyPriceOver()

Application.Calculation = xlCalculationManual

TimeToRun = Now + TimeValue("00:00:01") / 2

Application.OnTime TimeToRun, "CopyPriceOver"

Application.Calculation = xlCalculationAutomatic

End Sub

تم تعديل ديسمبر 4, 2012 بواسطه عباد

[أبو ليمونه]

هلا فيك ابونصار

فعلا هذا هو المطلوب

جزاك الله كل خير

وادخلك فسيح جناته

تحياتي لك

[ياسر خليل أبو البراء]

بارك الله فيك يا أبو نصار ، وجعل أعمالك في ميزان حسناتك يوم القيامة

[الـعيدروس]

الاخ الحبيب ياسر خليل

اشكرك جزيل الشكر على مرورك الكريم

تقبل تحياتي وشكري

[أبو ليمونه]

هلا فيك ابو نصار

راح اتعبك معاي

الان الثانية فيها 1000 جزأ من الثانية

هل استطيع تعديل الكود ليعمل كل 800 او كل 700 جزأ من الثانية

حاولت اقسمه على 1.5 او 1.7 بس شكل VBA مايقبل كسور

تحياتي لك

[الـعيدروس]

السلام عليكم

اخي الفاضل أبو ليمونه

بالنسبة لدالة TimeValue غير دقيقة في وضع الثواني

ولاكن بالامكان إستخدام Timer مع حلقة كالتالي

غير وضع الثواني من أول الكود في الوضع العام الى أي جزء في الثانية

Private Const H_Scond As Single = 0.5 ' 0.25 ' 0.1667

Private Const H_Scond As Single = 0.5 ' 0.25 ' 0.1667

Public Sub Tim_Ali()

Dim A_T As Single

A_T = Timer

While Timer - A_T < H_Scond

Wend

CopyPriceOver

End Sub

Private Sub CopyPriceOver()

MsgBox "مرحباً", vbInformation, "منتدى أوفسينا"

End Sub

[أبو ليمونه]

ابو نصار شكرا لك

الكود يعمل

لكن احس انه غير دقيق

دالة

TimeToRun = Now + TimeValue("00:00:01") / 2

تعمل بمرونه ودقة كل نص ثانية

هل هناك كود يعمل بدقه بدون ان يتجمد ملف الاكسل كل ثلث ثانية مثلا؟

تحياتي لك

واستفدت منك كثيرا

جزيت كل خير

[الـعيدروس]

طالما انت تريد تأخر من الكود مده معينه

بأعتقادي فلا مشكله في التجميد دام هو في حدود الوقت المستقطع

ان كان التجميد غير مستحب

جرب هذا التعديل

Private Const H_Scond As Single = 0.5 ' 0.25 ' 0.1667

Public Sub Tim_Ali()

Dim A_T As Single

A_T = Timer

While Timer - A_T < H_Scond

DoEvents

Wend

CopyPriceOver

End Sub

Private Sub CopyPriceOver()

MsgBox "مرحباً", vbInformation, "منتدى أوفسينا"

End Sub

أو بإستخدام TimeSerial اعتقد هذا انسب لك

Public R_A As Double

Public Const Scond_A = 0.5 ' 0.25 ' 0.1667

Public Const Macro_ON = "O_M"

Sub Star_A()

    R_A = Now + TimeSerial(0, 0, Scond_A)

    Application.OnTime EarliestTime:=R_A, Procedure:=Macro_ON, Schedule:=True

End Sub

Sub O_M()

MsgBox "مرحباً", vbExclamation, "منتدى أوفسينا"

End Sub

تم تعديل ديسمبر 9, 2012 بواسطه عباد

[أبو ليمونه]

هلا فيك ابونصار

صراحة انت مبدع

دالة TimeSerial تعمل بكل مرونه

الله يعطيك الف عافية

سؤال اخير

هل بالامكان ان اضع بدل الرقم 0.5 الخليه A1

حيث ان الخليه A1 تساوي 0.5

Private Const H_Scond As Single = A1

تحياتي لك

[الـعيدروس]

بتغير نوع المتغير بدلا من Single تحط String وإضافة علامتين التنصيص "$A$1"

ليصبح كالتالي

Private Const H_Scond As String = "$A$1"

وهذا السطر :

While Timer - A_T < H_Scond

بدلا من H_Scond تحط Val(Range(H_Scond)) ليصبح الكود بعد التعديلات كالاتي

Private Const H_Scond As String = "$A$1" ' Single = String ' A1 = "$A$1"

Public Sub Tim_Ali()

Dim A_T As Single

A_T = Timer

While Timer - A_T < Val(Range(H_Scond)) 'H_Scond = Val(Range(H_Scond))

DoEvents

Wend

CopyPriceOver

End Sub

Private Sub CopyPriceOver()

MsgBox "مرحباً", vbInformation, "منتدى أوفسينا"

End Sub

[أبو ليمونه]

هلا فيك ابو نصار

اللهم بارك فيه وارزقه من خيرات الدنيا والاخرة وادخله فسيح جناتك

الكود جميل جدا وكل يوم اتعلم شي جديد منك

سؤال بعد الاخير

انا قرأت ان API timer دقيق جدا بالتعامل مع الجزأ بالثانية

هل بالامكان تعديل الكود الى API timer

Option Explicit


Private Declare Function SetTimer Lib "user32" _

(ByVal hWnd As Long, _

ByVal nIDEvent As Long, _

ByVal uElapse As Long, _

ByVal lpTimerFunc As Long) As Long


Private Declare Function KillTimer Lib "user32" _

(ByVal hWnd As Long, _

ByVal nIDEvent As Long) As Long


Private m_TimerID As Long


'Note:  The duration is measured in milliseconds.

'		 1,000 milliseconds = 1 second

Public Sub StartTimer(ByVal Duration As Long)

	 'If the timer isn't already running, start it.

    If m_TimerID = 0 Then

	    If Duration > 0 Then

		    m_TimerID = SetTimer(0, 0, Duration, AddressOf TimerEvent)

		    If m_TimerID = 0 Then

			    MsgBox "Timer initialization failed!"

		    End If

	    Else

		    MsgBox "The duration must be greater than zero."

	    End If

    Else

	    MsgBox "Timer already started."

    End If

End Sub


Public Sub StopTimer()

	 'If the timer is already running, shut it off.

    If m_TimerID <> 0 Then

	    KillTimer 0, m_TimerID

	    m_TimerID = 0

    Else

	    MsgBox "Timer is not active."

    End If

End Sub


Public Property Get TimerIsActive() As Boolean

	 'A non-zero timer ID indicates that it's turned on.

    TimerIsActive = (m_TimerID <> 0)

End Property


Private Sub TimerEvent()

    Debug.Print "Timer event fired: "; Format$(Now, "long time")

End Sub

تحياتي لك

تم تعديل ديسمبر 12, 2012 بواسطه أبو ليمونه

[الـعيدروس]

السلام عليكم

تفضل

Public Declare Sub Sleep Lib "kernel32" (ByVal A_Scound As Long)

Public Sub Ali_API()

DoEvents

'1000 ' إنتظار ثانية

' 500 ' إنتظار نصف ثانية وهكذا

Sleep (500)

Ali_Time

Exit Sub

End Sub

Private Sub Ali_Time()

MsgBox "مرحباً", vbExclamation, "منتدى أوفسينا"

End Sub

تم تعديل ديسمبر 12, 2012 بواسطه عباد

[أبو ليمونه]

ابونصار

الله يوفقك لكل خير .....الكود يعمل بكل مرونه

شكرا لك

واتعبتك معاي

تحياتي وتقديري لك