Timer auf user form in Excel-VBA

Ich brauchte ein sichtbarer countdown-timer, die bleiben könnte, oben auf anderen Fenstern und laufen flüssig, ob änderungen an der Arbeitsmappe, oder minimieren Sie das Excel-Fenster. So, angepasst ich die @don-kirkby, kreative code oben für meine eigenen Zwecke und dachte, ich würde teilen die Folge.



Der code unten erfordert die Erstellung von ein Modul und eine userform wie bereits angemerkt in den Kommentaren, oder Sie können download der .xlsm am Ende dieser Antwort.

Benutzte ich die Windows-Zeitgeber-API für genaue und glatte countdown (und auch anpassbare runter auf ~100 Millisekunden timer-Auflösung, je nach Prozessor. Es gibt sogar einen "tick tock" sound.

Legen Sie ein neues Modul und speichern Sie es als modUserFormTimer. Fügen Sie zwei Formular-Steuerelement-Schaltflächen Sie zu dem Arbeitsblatt, beschriftet mit Start Timer und Stop Timer und zugeordnet Verfahren btnStartTimer_Click und 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

Nächsten, eine userform erstellen, speichern Sie es als frmTimer. Fügen Sie ein Textfeld namens txtCountdown. Set property ShowModal zu False. Fügen Sie folgenden code-Fenster des Formulars:

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

Download demo .xksm. hier. Es gibt zahlreiche Möglichkeiten, dies kann besonders angefertigt werden bzw. auf die individuellen Bedürfnisse abgestimmt. Ich werde es verwenden, um zu berechnen und die Anzeige von Echtzeit-Statistiken aus einer beliebten Q&Eine Seite in der Ecke von meinem Bildschirm...

_{Hinweis das, denn es enthält VBA-Makros, die Datei könnte möglicherweise legen Sie Ihr Viren-scanner (wie jede andere nicht-lokale Datei mit VBA). Wenn Sie besorgt sind, laden Sie keine, und stattdessen bauen Sie sich mit den Informationen zur Verfügung gestellt.)}

InformationsquelleAutor ashleedawg