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 mit der VBA-intenen Funktion Timer eine Verzögerung einbauen. Das hat den Nachteil, dass VBA permanent im Hintergrund weiterläuft.

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 dabei losgelöst von VBA.

In den Formularen von Microsoft Access sind derartige Timer übrigens schon eingebaut und können über die Formulareigenschaften eingestellt werden. Ein API-Aufruf, wie er hier beschrieben wird, ist dort 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

    Private hEvent 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

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

    Private hEvent As Long
#End If

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:

hWnd As LongPtr Das Handle aus SetTimer
uMsg As LongPtr Der Wert beträgt in VBA immer 275 (= API-Konstante WM_TIMER)
wParam As LongPtr Das der ID (nIDEvent)des Timers
lParam As LongPtr Anzahl der Millisekunden seit dem Systemstart (siehe auch GetTickCount)

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

    Private lngStart 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

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

    Private lngStart As Long
#End If


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

KillTimer SetTimer