مؤقت على نموذج المستخدم في Excel VBA
سؤال
لقد حصلت على بعض رمز Excel VBA القديم حيث أرغب في تشغيل مهمة على فترات منتظمة. إذا كنت أستخدم VB6 ، لكنت قد استخدمت التحكم في المؤقت.
لقد وجدت application.ontime () الطريقة ، وهي تعمل بشكل جيد للرمز الذي يتم تشغيله في ورقة عمل Excel ، لكن لا يمكنني جعلها تعمل في نموذج مستخدم. الطريقة لا يتم استدعاؤها.
كيف يمكنني جعل التطبيق. ontime () استدعاء طريقة في نموذج المستخدم ، أو هل هناك طرق أخرى لجدولة التعليمات البرمجية لتشغيلها في VBA؟
المحلول
لقد وجدت حلًا عن ذلك. إذا قمت بكتابة طريقة في وحدة نمطية تستدعي طريقة في نموذج المستخدم الخاص بك ، فيمكنك جدولة طريقة الوحدة باستخدام Application.ontime ().
نوع من kludge ، لكنه سوف يفعل ما لم يكن لدى شخص ما اقتراح أفضل.
هذا مثال:
''//Here's the code that goes in the user form
Dim nextTriggerTime As Date
Private Sub UserForm_Initialize()
ScheduleNextTrigger
End Sub
Private Sub UserForm_Terminate()
Application.OnTime nextTriggerTime, "modUserformTimer.OnTimer", Schedule:=False
End Sub
Private Sub ScheduleNextTrigger()
nextTriggerTime = Now + TimeValue("00:00:01")
Application.OnTime nextTriggerTime, "modUserformTimer.OnTimer"
End Sub
Public Sub OnTimer()
''//... Trigger whatever task you want here
''//Then schedule it to run again
ScheduleNextTrigger
End Sub
''// Now the code in the modUserformTimer module
Public Sub OnTimer()
MyUserForm.OnTimer
End Sub
نصائح أخرى
كنت بحاجة إلى مؤقت للعد التنازلي المرئي الذي يمكن أن يبقى على رأس النوافذ الأخرى ويدير بسلاسة ما إذا كان إجراء تغييرات على المصنف ، أو تقليل نافذة Excel. لذا ، قمت بتكييف @Don-Kirkby's Creative رمز أعلاه لأغطيتي الخاصة وأحسب سأشارك النتيجة.
يتطلب الكود أدناه إنشاء وحدة ونمط مستخدم كما هو مذكور في التعليقات ، أو يمكنك تنزيل .xlsm
في أسفل هذه الإجابة.
لقد استخدمت Windows Timer API للعد التنازلي الأكثر دقة وسلسة (وأيضًا قابلاً للتخصيص إلى حوالي 100 ميلي ثانية قرار المؤقت, ، اعتمادا على المعالج الخاص بك. حتى أن هناك "tock tock" يبدو. ⏰
أدخل وحدة جديدة وحفظها modUserFormTimer
. أضف اثنين أزرار أوامر التحكم في النموذج إلى ورقة العمل ، المسمى بدء توقيت و توقف مؤقت و تعيين إجراءات btnStartTimer_Click
و btnStopTimer_Click
.
Option Explicit 'modUserFormTimer
Public Const showTimerForm = True 'timer runs with/without the userform showing
Public Const playTickSound = True 'tick tock (a WAV sounds could be embedded: `https:// goo.gl/ ReuUyd`)
Public Const timerDuration = "00:00:20" 'could also Insert>Object a WAV for tick or alarm
Public Const onTimerStart_MinimizeExcel = True 'minimize Excel? (countdown remains visible)
Public Const onTimerStart_MaximizeExcel = True 'maximize Excel when timer completes?
'timer could be on top of other applications; instructions here: `https:// goo.gl/ AgmWrM`
'safe for 32 or 64 bit Office:
Private Declare PtrSafe Function SetTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Public Declare PtrSafe Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Public schedTime As Date 'this is the "major" timer set date
Private m_TimerID As Long
Public Sub OnTimerTask()
'the procedure that runs on completion of the "major timer" (timer won't reschedule)
Unload frmTimer
''''''''''''''''''''''''''''''
MsgBox "Do Something!" ' < < < < < Do Something Here
''''''''''''''''''''''''''''''
End Sub
Public Sub btnStartTimer_Click()
schedTime = Now() + TimeValue(timerDuration)
InitTimerForm
End Sub
Public Sub btnStopTimer_Click()
'clicking the 'x' on the userform also ends the timer (disable the close button to force continue)
schedTime = 0
frmTimer.UserForm_Terminate
End Sub
Public Sub InitTimerForm()
'run this procedure to start the timer
frmTimer.OnTimer
Load frmTimer
If showTimerForm Then
If onTimerStart_MinimizeExcel Then Application.WindowState = xlMinimized
frmTimer.Show 'timer will still work if userform is hidden (could add a "hide form" option)
End If
End Sub
Public Sub StartTimer(ByVal Duration As Long)
'Begin Millisecond Timer using Windows API (called by UserForm)
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!", vbCritical, "Timer"
End If
Else
MsgBox "The duration must be greater than zero.", vbCritical, "Timer"
End If
Else
MsgBox "Timer already started.", vbInformation, "Timer"
End If
End Sub
Public Sub StopTimer()
If m_TimerID <> 0 Then 'check if timer is active
KillTimer 0, m_TimerID 'it's active, so kill it
m_TimerID = 0
End If
End Sub
Private Sub TimerEvent()
'the API calls this procedure
frmTimer.OnTimer
End Sub
بعد ذلك ، قم بإنشاء مستخدم ، احفظه كـ frmTimer
. إضافة مربع نص اسمه txtCountdown
. تعيين خاصية ShowModal
ل False
. الصق ما يلي في نافذة رمز النموذج:
Option Explicit 'code for userform "frmTimer"
'requires a textbox named "txtCountdown" and "ShowModal" set to False.
Dim nextTriggerTime As Date
Private Sub UserForm_Initialize()
ScheduleNextTrigger
End Sub
Public Sub UserForm_Terminate()
StopTimer
If schedTime > 0 Then
schedTime = 0
End If
If onTimerStart_MaximizeExcel Then Application.WindowState = xlMaximized 'maximize excel window
Unload Me
End Sub
Private Sub ScheduleNextTrigger() 'sets the "minor" timer (for the countdown)
StartTimer (1000) 'one second
End Sub
Public Sub OnTimer()
'either update the countdown, or fire the "major" timer task
Dim secLeft As Long
If Now >= schedTime Then
OnTimerTask 'run "major" timer task
Unload Me 'close userForm (won't schedule)
Else
secLeft = CLng((schedTime - Now) * 60 * 60 * 24)
If secLeft < 60 Then 'under 1 minute (don't show mm:ss)
txtCountdown = secLeft & " sec"
Else
'update time remaining in textbox on userform
If secLeft > 60 * 60 Then
txtCountdown = Format(secLeft / 60 / 60 / 24, "hh:mm:ss")
Else 'between 59 and 1 minutes remain:
txtCountdown = Right(Format(secLeft / 60 / 60 / 24, "hh:mm:ss"), 5)
End If
End If
If playTickSound Then Beep 16000, 65 'tick sound
End If
End Sub
قم بتنزيل العرض التوضيحي .xksm.
هنا. هناك طرق عديدة يمكن تخصيصها أو تكييفها مع احتياجات محددة. سأستخدمه في محسوبة وعرض الإحصائيات في الوقت الفعلي من موقع أسئلة وأجوبة شهيرة في زاوية شاشتي ...
ملحوظة نظرًا لأنه يحتوي على Macro VBA ، فقد يقوم الملف بإزالة الماسح الضوئي للفيروسات (كما هو الحال مع أي ملف آخر غير محلي مع VBA). إذا كنت تشعر بالقلق ، فلا تنزيل ، وبدلاً من ذلك ، قم ببناءها بنفسك بالمعلومات المقدمة.)
ماذا عن نقل كل الكود إلى وحدة "مؤقت".
Dim nextTriggerTime As Date
Dim timerActive As Boolean
Public Sub StartTimer()
If timerActive = False Then
timerActive = True
Call ScheduleNextTrigger
End If
End Sub
Public Sub StopTimer()
If timerActive = True Then
timerActive = False
Application.OnTime nextTriggerTime, "Timer.OnTimer", Schedule:=False
End If
End Sub
Private Sub ScheduleNextTrigger()
If timerActive = True Then
nextTriggerTime = Now + TimeValue("00:00:01")
Application.OnTime nextTriggerTime, "Timer.OnTimer"
End If
End Sub
Public Sub OnTimer()
Call MainForm.OnTimer
Call ScheduleNextTrigger
End Sub
الآن يمكنك الاتصال من mainform:
call Timer.StartTimer
call Timer.StopTimer
لمنع الأخطاء ، أضف:
Private Sub UserForm_Terminate()
Call Timer.StopTimer
End Sub
سوف يثير:
Public Sub OnTimer()
Debug.Print "Tick"
End Sub