Timer

Gelegentlich kann es sinnvoll sein, eine Prozedur wieder und wieder ablaufen zu lassen. Dazu könnte man beispielsweise den Prozeduraufruf in eine Endlosschleife packen und darin bei Bedarf eine Verzögerung einbauen.

Sub endlos()
Dim i As Single

i = Timer

Do
    Do Until i + 3 < Timer    '3 Sekunden warten
        DoEvents
    Loop
    Uhrzeit
Loop
End Sub

Public Sub Uhrzeit() Debug.Print Time 'Uhrzeit ausgeben End Sub

Dieses Beispiel startet alle drei Sekunden eine Prozedur namens Uhrzeit. Der Nachteil dabei ist, dass für die Prozedur endlos VBA permanent im Hintergrund weiterläuft. Das wird besonders kompliziert, wenn vielleicht noch ganz andere Aktionen ablaufen sollen, die unabhängig davon sind.

Stattdessen kann man auch den API-Aufruf SetTimer verwenden, der die Überwachung unabhängig von VBA übernimmt. Mit KillTimer kann der Timer wieder beendet werden. Im folgenden Beispiel kann mit demoTimerAn ein neuer Timer generiert werden, der mit demoTimerAus wieder zerstört wird. Die Überwachung des Timers verläuft inzwischen losgelöst von VBA. Derartige Timer sind in den Formularen von Microsoft Access übrigens schon eingebaut und können über die Formulareigenschaften eingestellt werden. Dort ist ein API-Aufruf, wie er hier beschrieben wird, also nicht notwendig.

#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr , _
        ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr

    Private Declare PtrSafe Function KillTimer Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
    Private Declare Function SetTimer Lib "user32" ( _
        ByVal hWnd As Long, ByVal nIDEvent As Long, _
        ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

    Private Declare Function KillTimer Lib "user32" ( _
        ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
#End If

Private hEvent As LongPtr

Public Sub
demoTimerAn(ByVal Intervall As Long) If hEvent <> 0 Then Exit Sub hEvent = SetTimer(0, 0, Intervall, AddressOf Uhrzeit) End Sub
Public Sub
demoTimerAus() If hEvent = 0 Then Exit Sub KillTimer 0 , hEvent hEvent = 0 End Sub
Public Sub Uhrzeit() Debug.Print Time 'Uhrzeit ausgeben End Sub

KillTimer

Löscht einen Timer, der zuvor mit SetTimer gestartet wurde. Die Parameter müssen denen entsprechen, die mit SetTimer gesetzt wurden.

#If VBA7 Then
    Private Declare PtrSafe Function KillTimer Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
    Private Declare Function KillTimer Lib "user32" ( _
        ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
#End If

SetTimer

Startet einen neuen Timer oder ändert einen bestehenden Timer. Jeder Timer hat eine ID, die von der Funktion zurückgegeben wird. War die Funktion nicht erfolgreich, ist der Rückgabewert 0.

#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr , _
        ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr

#Else
    Private Declare Function SetTimer Lib "user32" ( _
        ByVal hWnd As Long, ByVal nIDEvent As Long, _
        ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
#End If

Mit hWnd kann der Timer an ein Fensterhandle innerhalb der aktuellen Applikation gebunden werden, also beispielsweise ein VBA-Formular. Wird das Formular geschlossen, während der Timer noch aktiv ist, wird zugleich auch der Timer beendet. Um einen Timer zu erstellen, der unabängig von einem Formular arbeitet, kann auch 0 angegeben werden.

nIDEvent ist der ID des aktuellen Timers. Zusammen mit hWnd ist der ID eindeutig. Ist dieser Parameter 0, wird ein neuer Timer erstellt und die Funktion gibt eine neue, eindeutige ID zurück. Entspricht der Parameter der ID eines schon exisiterenden Timers mit gleichem hWnd, wird dieser Timer mit den neuen Werten überschrieben.

uElapse gibt an, nach wie vielen Millisekunden das Timerereignis jeweils wiederholt werden soll (Da der interne Taktgeber von Windows üblicherweise auf 15,7 Millisekunden eingestellt ist, wären kleinere Werte als „16“ nicht sinnvoll).

lpTimerFunc ist die Prozeduradresse derjenigen Funktion, die durch das Timerereignis ausgelöst werden soll. Wenn mit hWnd ein Fenster angegeben wurde, das ein Standardereignis besitzt, kann hier auch 0 angegeben werden - dann wird dieses Standardereignis ausgelöst. Die angesprochene Funktion bekommt automatisch folgende Parameter übergeben:

Mit diesen Parametern kann also überprüft werden, welcher Timer die Funktion aufgerufen hat und wie lange er schon läuft. Im folgenden Beispiel wird das genutzt, um einen Timer nach 10 Sekunden automatisch zu beenden.

#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr , _
        ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr

    Private Declare PtrSafe Function KillTimer Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
    Private Declare Function SetTimer Lib "user32" ( _
        ByVal hWnd As Long, ByVal nIDEvent As Long, _
        ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

    Private Declare Function KillTimer Lib "user32" ( _
        ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
#End If

Private lngStart As LongPtr

Public Sub
demoTimerAn(ByVal msInterval As Long) lngStart = 0 SetTimer 0, 0, msInterval, AddressOf Uhr10s End Sub
Public Sub
Uhr10s(ByVal hWnd As LongPtr, ByVal uMsg As LongPtr, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) Select Case lngStart Case 0 'Startzeitpunkt merken lngStart = lParam Debug.Print "Start" Case Is < (lParam - 10000) 'nach 10 Sekunden beenden lngStart = 0 KillTimer hWnd, wParam Debug.Print "Ende" Case Else 'Uhrzeit ausgeben Debug.Print Time End Select End Sub