Excel VBA中用户表单上的计时器

Question

我有一些旧的Excel VBA代码,我想定期运行任务.如果我使用VB6,我会使用定时器控件.

我找到了Application.OnTime()方法,它适用于在Excel工作表中运行的代码,但我不能使它在用户表单中工作.该方法永远不会被调用.

如何使Application.OnTime()以用户身份调用方法,还是有其他方法来安排代码在VBA中运行？

Answer 1

我找到了解决方法.如果在只调用用户表单中的方法的模块中编写方法,则可以使用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

Answer 2

我需要一个可见的倒计时器，无论是更改工作簿还是最小化 Excel 窗口，它都可以保持在其他窗口之上并平稳运行。因此，我出于自己的目的改编了上面@don-kirkby 的创意代码，并认为我会分享结果。
\n\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82 \xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2 \x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82\xe2\x80\x82
\n下面的代码需要创建一个模块和一个用户表单，如评论中所述，或者您可以.xlsm在本答案的底部下载。

\n\n

我使用Windows 计时器 API来实现更准确、更流畅的倒计时（还可以根据您的处理器定制低至约 100 毫秒的计时器分辨率。甚至还有“滴答声” 。 \xe2\x8f\xb0

\n\n

插入一个新模块并将其另存为modUserFormTimer. 将两个表单控制命令按钮添加到工作表中，分别标记为Start Timer和Stop Timer以及分配的过程btnStartTimer_Click和btnStopTimer_Click。

\n\n

Option Explicit \'modUserFormTimer\n\nPublic Const showTimerForm = True \'timer runs with/without the userform showing\nPublic Const playTickSound = True \'tick tock (a WAV sounds could be embedded: `https:// goo.gl/ ReuUyd`)\nPublic Const timerDuration = "00:00:20" \'could also Insert>Object a WAV for tick or alarm\nPublic Const onTimerStart_MinimizeExcel = True \'minimize Excel? (countdown remains visible)\nPublic Const onTimerStart_MaximizeExcel = True \'maximize Excel when timer completes?\n\'timer could be on top of other applications; instructions here: `https:// goo.gl/ AgmWrM`\n\n\'safe for 32 or 64 bit Office:\nPrivate Declare PtrSafe Function SetTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long, _\nByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long\nPrivate Declare PtrSafe Function KillTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long\nPublic Declare PtrSafe Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long\n\nPublic schedTime As Date \'this is the "major" timer set date\nPrivate m_TimerID As Long\n\nPublic Sub OnTimerTask()\n\'the procedure that runs on completion of the "major timer" (timer won\'t reschedule)\n    Unload frmTimer\n\n    \'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\n    MsgBox "Do Something!"       \' < < < < <  Do Something Here\n    \'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\'\n\nEnd Sub\n\nPublic Sub btnStartTimer_Click()\n    schedTime = Now() + TimeValue(timerDuration)\n    InitTimerForm\nEnd Sub\n\nPublic Sub btnStopTimer_Click()\n    \'clicking the \'x\' on the userform also ends the timer (disable the close button to force continue)\n    schedTime = 0\n    frmTimer.UserForm_Terminate\nEnd Sub\n\nPublic Sub InitTimerForm()\n\'run this procedure to start the timer\n    frmTimer.OnTimer\n    Load frmTimer\n    If showTimerForm Then\n        If onTimerStart_MinimizeExcel Then Application.WindowState = xlMinimized\n        frmTimer.Show  \'timer will still work if userform is hidden (could add a "hide form" option)\n    End If\nEnd Sub\n\nPublic Sub StartTimer(ByVal Duration As Long)\n    \'Begin Millisecond Timer using Windows API (called by UserForm)\n    If m_TimerID = 0 Then\n        If Duration > 0 Then\n            m_TimerID = SetTimer(0, 0, Duration, AddressOf TimerEvent)\n            If m_TimerID = 0 Then\n                MsgBox "Timer initialization failed!", vbCritical, "Timer"\n            End If\n        Else\n            MsgBox "The duration must be greater than zero.", vbCritical, "Timer"\n        End If\n    Else\n        MsgBox "Timer already started.", vbInformation, "Timer"\n    End If\nEnd Sub\n\nPublic Sub StopTimer()\n    If m_TimerID <> 0 Then \'check if timer is active\n        KillTimer 0, m_TimerID \'it\'s active, so kill it\n        m_TimerID = 0\n    End If\nEnd Sub\n\nPrivate Sub TimerEvent()\n\'the API calls this procedure\n    frmTimer.OnTimer\nEnd Sub\n

\n\n

接下来，创建一个用户表单，将其另存为frmTimer. 添加一个名为 的文本框txtCountdown。将属性设置ShowModal为False. 将以下内容粘贴到表单的代码窗口中：

\n\n

Option Explicit \'code for userform "frmTimer"\n\'requires a textbox named "txtCountdown" and "ShowModal" set to False.\n\nDim nextTriggerTime As Date\n\nPrivate Sub UserForm_Initialize()\n    ScheduleNextTrigger\nEnd Sub\n\nPublic Sub UserForm_Terminate()\n    StopTimer\n    If schedTime > 0 Then\n        schedTime = 0\n    End If\n    If onTimerStart_MaximizeExcel Then Application.WindowState = xlMaximized \'maximize excel window\n    Unload Me\nEnd Sub\n\nPrivate Sub ScheduleNextTrigger() \'sets the "minor" timer (for the countdown)\n    StartTimer (1000) \'one second\nEnd Sub\n\nPublic Sub OnTimer()\n\'either update the countdown, or fire the "major" timer task\n    Dim secLeft As Long\n    If Now >= schedTime Then\n        OnTimerTask \'run "major" timer task\n        Unload Me  \'close userForm (won\'t schedule)\n    Else\n        secLeft = CLng((schedTime - Now) * 60 * 60 * 24)\n        If secLeft < 60 Then \'under 1 minute (don\'t show mm:ss)\n            txtCountdown = secLeft & " sec"\n        Else\n            \'update time remaining in textbox on userform\n            If secLeft > 60 * 60 Then\n                txtCountdown = Format(secLeft / 60 / 60 / 24, "hh:mm:ss")\n            Else \'between 59 and 1 minutes remain:\n                txtCountdown = Right(Format(secLeft / 60 / 60 / 24, "hh:mm:ss"), 5)\n            End If\n        End If\n       If playTickSound Then Beep 16000, 65 \'tick sound\n    End If\nEnd Sub\n

\n\n

.xksm.在此处下载演示。有多种方法可以定制或适应特定需求。我将使用它来计算并在屏幕一角显示来自流行问答网站的实时统计数据......

\n\n

_{请注意，由于它包含 VBA 宏，因此该文件可能会触发您的病毒扫描程序（与使用 VBA 的任何其他非本地文件一样）。如果您担心，请不要下载，而是使用提供的信息自行构建。）}

\n