Excel VBA中用户窗体上的计时器
我有一些旧的Excel VBA代码,我想在其中定期运行任务。如果我使用VB6,我会使用定时器控件 我找到了这个方法,它适用于Excel工作表中运行的代码,但我无法让它在用户表单中运行。该方法从未被调用Excel VBA中用户窗体上的计时器,vba,excel,userform,Vba,Excel,Userform,我有一些旧的Excel VBA代码,我想在其中定期运行任务。如果我使用VB6,我会使用定时器控件 我找到了这个方法,它适用于Excel工作表中运行的代码,但我无法让它在用户表单中运行。该方法从未被调用 如何使Application.OnTime()调用用户窗体中的方法,或者是否有其他方法来安排代码在VBA中运行?我找到了一种解决方法。如果在模块中编写的方法只调用用户窗体中的方法,则可以使用Application.OnTime()调度模块方法 有点混乱,但除非有人有更好的建议,否则就行了 下面是一
如何使Application.OnTime()调用用户窗体中的方法,或者是否有其他方法来安排代码在VBA中运行?我找到了一种解决方法。如果在模块中编写的方法只调用用户窗体中的方法,则可以使用Application.OnTime()调度模块方法 有点混乱,但除非有人有更好的建议,否则就行了 下面是一个例子:
''//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
将所有代码移到“计时器”模块中如何
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
现在您可以从主窗体调用:
call Timer.StartTimer
call Timer.StopTimer
要防止错误,请添加:
Private Sub UserForm_Terminate()
Call Timer.StopTimer
End Sub
Wich将触发:
Public Sub OnTimer()
Debug.Print "Tick"
End Sub
我需要一个可见的倒计时计时器,它可以保持在其他窗口的顶部,并且无论是更改工作簿还是最小化Excel窗口,都可以平稳运行。因此,我根据自己的目的改编了@don kirkby's creative,并想与大家分享结果。
下面的代码需要创建一个模块和一个用户表单,如注释中所述,或者您可以下载此答案底部的
.xlsm
我使用的是更精确、更平滑的倒计时(也可以自定义到~100毫秒,具体取决于您的处理器。甚至还有一个“滴答声”。⏰
插入一个新模块,并将其另存为modUserFormTimer
。在工作表中添加两个模块,分别标记为启动计时器和停止计时器以及过程btnStartTimer\u单击
和btnStopTimer\u单击
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
。有很多方法可以根据具体需要进行定制或调整。我将使用它来计算和显示屏幕角落中流行问答网站的实时统计数据
注意由于该文件包含VBA宏,因此可能会启动病毒扫描程序(与任何其他带有VBA的非本地文件一样)。如果您担心,请不要下载,而是使用提供的信息自行构建。)感谢用户1575005 使用模块中的代码设置计时器()进程:
我想那是唯一的办法,唐。
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
Dim nextTriggerTime As Date
Dim timerActive As Boolean
Public Sub StartTimer()
Debug.Print Time() & ": Start"
If timerActive = False Then
timerActive = True
Call ScheduleNextTrigger
End If
End Sub
Public Sub StopTimer()
If timerActive = True Then
timerActive = False
Application.OnTime nextTriggerTime, "OnTimer", Schedule:=False
End If
Debug.Print Time() & ": End"
End Sub
Private Sub ScheduleNextTrigger()
If timerActive = True Then
nextTriggerTime = Now + TimeValue("00:00:10")
Application.OnTime nextTriggerTime, "OnTimer"
End If
End Sub
Public Sub OnTimer()
Call bus_OnTimer
Call ScheduleNextTrigger
End Sub
Public Sub bus_OnTimer()
Debug.Print Time() & ": Tick"
Call doWhateverUwant
End Sub
Private Sub doWhateverUwant()
End Sub