3

我有一些旧的 Excel VBA 代码，我想在其中定期运行任务。如果我使用的是 VB6，我会使用计时器控件。

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

如何让 Application.OnTime() 在用户表单中调用方法，或者是否有其他方法可以安排代码在 VBA 中运行？

4

4 回答 4

8

我找到了解决方法。如果您在一个模块中编写一个只调用用户表单中的方法的方法，那么您可以使用 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
于 2009-10-13T21:13:06.943 回答
4

我需要一个可见的倒计时计时器，它可以保持在其他窗口的顶部并且无论是对工作簿进行更改还是最小化 Excel 窗口都可以顺利运行。因此，我出于自己的目的改编了上面@don-kirkby 的创意代码，并认为我会分享结果。
                      <a href="https://i.stack.imgur.com/P7FTS.gif" rel="nofollow noreferrer">倒计时截图
下面的代码需要创建一个模块和一个用户表单，如注释中所述，或者您可以下载.xlsm在这个答案的底部。

我使用Windows Timer API来获得更准确和更流畅的倒计时（并且还可以自定义到 ~100 毫秒的计时器分辨率，具体取决于您的处理器。甚至还有“滴答”的声音。⏰</p>

插入一个新模块并将其另存为modUserFormTimer. 将两个表单控制命令按钮添加到工作表，分别标记Start Timer和分配过程Stop Timer和。btnStartTimer_ClickbtnStopTimer_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.在此处下载演示。有多种方法可以定制或适应特定需求。我将使用它来计算和显示来自我屏幕一角流行问答网站的实时统计数据......

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

于 2018-06-06T15:36:55.363 回答
0

将所有代码移至“计时器”模块怎么样？

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

将触发：

Public Sub OnTimer()
    Debug.Print "Tick"
End Sub
于 2017-07-10T03:10:05.847 回答
0

感谢 user1575005 ！

使用模块中的代码设置 Timer() 进程：

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
于 2019-10-08T22:12:01.827 回答