Excel VBA中用戶表單上的計時器

Question

我有一些舊的 Excel VBA 代碼，我想在其中定期運行任務。 如果我使用 VB6，我會使用計時器控件。

我找到了Application.OnTime()方法，它適用於在 Excel 工作表中運行的代碼，但我無法使其在用戶表單中工作。 該方法永遠不會被調用。

如何讓 Application.OnTime() 調用用戶表單中的方法，或者是否有其他方法可以安排代碼在 VBA 中運行？

Answer 1

我找到了一個解決方法。 如果你在一個模塊中編寫一個方法來調用你的用戶表單中的一個方法，那么你可以使用 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

Answer 2

我需要一個可見的倒數計時器，無論是對工作簿進行更改，還是最小化 Excel 窗口，它都可以停留在其他窗口的頂部並且平穩運行。 因此，我根據自己的目的改編了上面@don-kirkby 的創意代碼，並認為我會分享結果。

下面的代碼需要創建一個模塊和一個用戶表單，如注釋中所述，或者您可以下載此答案底部的.xlsm 。

我使用了Windows Timer API來實現更准確和平滑的倒計時（並且還可以自定義低至約 100 毫秒的計時器分辨率，具體取決於您的處理器。甚至還有“滴答” 聲。⏰

插入一個新模塊並將其保存為modUserFormTimer 。 將兩個表單控件命令按鈕添加到工作表，標記為Start Timer和Stop Timer並分配過程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 ，將其保存為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 的非本地文件一樣）。 如果您擔心，請不要下載，而是使用提供的信息自行構建。）}

Answer 3

將所有代碼移動到“計時器”模塊如何。

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

Answer 4

感謝 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