Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0763: LongTimer: Timer über lange Zeitspannen

VB 5/6-Tipp 0763: LongTimer: Timer über lange Zeitspannen

 von OlimilO

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [5.6 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Rahmensteuerelement "FraTimer"
' Steuerelement: Optionsfeld-Steuerelement "Option3" auf FraTimer
' Steuerelement: Textfeld "TxtXTimes" auf FraTimer
' Steuerelement: Optionsfeld-Steuerelement "Option2" auf FraTimer
' Steuerelement: Optionsfeld-Steuerelement "Option1" auf FraTimer
' Steuerelement: Textfeld "TxtSeconds"
' Steuerelement: Schaltfläche "BtnStart"
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit
Private WithEvents mTim As LongTimer
'Das Interval eines VB.Timers läßt sich maximal bis zu einem Wert von 65535 einstellen
'(das sind 65 Sekunden und 535 Millisekunden).
'Was kann man tun, wenn man einen Timer benötigt, der jedoch viel längere Intervalle
'akzeptieren soll, mehrere Minuten, Stunden, Wochen oder gar Jahre?
'Wie kann man die benötigte Verzögerung erreichen?
'Die Antwort ist ganz simpel. Man setzt den Timer in eine Klasse die das Timerereignis
'nach der maximalen Zeitspanne abfängt, um dann seinerseits zum benötigten Zeitpunkt
'ein Event zu werfen.
'Dabei ist es leicht verschmerzbar, auf eine Millisekundenangabe zu verzeichten, da es
'bei sehr langen Zeitspannen normalerweise nicht auf die Millisekunde ankommt.
'Eine zeitliche Auflösungsgenauigkeit von Sekunden ist für diese Zwecke normalerweise
'ausreichend.
'Außerdem kann die Häufigkeit des Timerereignisses eingestellt werden. So kann der Timer
'entweder ein Einzigesmal (FireOnce), oder eine bestimtme Anzahl (FireXTimes) oder
'andauernd (FirePermanent) feuern.

Private Sub Form_Load()
   'Ein VB.Timer-Control mit Namen Timer1 muß auf dem Formular vorhanden sein.
   Option3.Value = True
End Sub

Private Sub BtnStart_Click()
    Set mTim = New_LongTimer(Me.Timer1, GetFireKind, GetFireCount)
    If IsNumeric(TxtSeconds.Text) Then
        mTim.IntervalSec = CLng(TxtSeconds.Text)
    End If
    Label1.Caption = mTim.ToString & "   " & CStr(Time)
    List1.Clear
    mTim.Enabled = True
End Sub

Private Sub mTim_Timer()
    'dieses Ereignis kommt nicht direkt von der VB.Timer-Komponente
    'sondern von der Klasse LongTimer
    Call List1.AddItem(mTim.ToString & "   " & CStr(Time))
End Sub
 
Private Function GetFireKind() As FireKind
    If Option3.Value Then GetFireKind = FirePermanent
    If Option2.Value Then GetFireKind = FireXTimes
    If Option1.Value Then GetFireKind = FireOnce
End Function
Private Function GetFireCount() As Long
    If Option2.Value Then
        If IsNumeric(TxtXTimes.Text) Then
            GetFireCount = CLng(TxtXTimes.Text)
        End If
    End If
End Function

Private Sub Option1_Click()
    TxtXTimes.Enabled = False
End Sub
Private Sub Option2_Click()
    TxtXTimes.Enabled = True
End Sub
Private Sub Option3_Click()
    TxtXTimes.Enabled = False
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------ Anfang Klasse "LongTimer" alias LongTimer.cls  ------
Option Explicit
Public Enum FireKind
    FirePermanent
    FireXTimes
    FireOnce
End Enum
Private WithEvents mTim As VB.Timer
'Maximal 60 Sek. das macht der VB.Timer noch gut mit:
Private Const mCMaxI    As Long = 60
Private mInterval       As Long
'speichert die Anzahl der Intervalle die bisher verstrichen sind:
Private mIntervals      As Long
'speichert den Divisionrest von mInterval Mod mMaxI:
Private mModIntMax      As Long
Private mFireKind       As FireKind
'zählt nach oben, bis mCount
Private mXTime          As Long
'speichert wie oft der Timer bei Firekind.FireXTimes insgesamt melden soll
Private mCount          As Long

Public Event Timer()
'ein lustiger Timer,
'der soll lange Zeitspannen überbrücken können
'also nicht nur die maximal 65535 ms des VB Timers
'sondern noch viiiiel länger,
'Sekunden
'Minuten
'Stunden
'Wochen
'Monate
'Jahre
'Tage
'##########
'1 Sek = 1000 ms
'1 Min = 60 Sek
'1 Std = 3600 Sek.
'1 Tag = 86400 Sek.
'1 Week = 604800 Sek.
'1 Year(365Tage) = 31536000 Sek.
'
'2147483647
'31536000
'max 68 Jahre in einem Long, das dürfte fürs erste reichen ;)

'
' #################### ' v  Public Procedures  v  ' #################### '
Public Sub NewC(aTim As VB.Timer, _
                Optional ByVal aFKind As FireKind = FirePermanent, _
                Optional ByVal aCount As Long)
    Set mTim = aTim
    mTim.Enabled = False
    mFireKind = aFKind
    mCount = aCount       'die Anzahl insgesamt
End Sub

'ReadOnly
Public Property Get Count() As Long
    Count = mCount
End Property
Public Property Get XTime() As Long
    XTime = mXTime
End Property

Public Property Get FireKind() As FireKind
    FireKind = mFireKind
End Property
Public Property Let FireKind(RHS As FireKind)
    mFireKind = RHS
End Property

Public Property Get Enabled() As Boolean
    Enabled = mTim.Enabled
End Property
Public Property Let Enabled(RHS As Boolean)
    mTim.Enabled = RHS
End Property

'die folgenden beiden Funktionen können ganz nützlich sein, falls
'der User den Timer von Hand schalten kann, und das Programm trotzdem
'unabhängig von der Usereinstellung den Timer ein/ausschalten muß.
'Einfach den zurückgegebenen Wert in einer Variablen speichern, und den
'gespeicherten Wert mit Property Let Enabled wieder setzen.
Public Function DisableTimer() As Boolean
    DisableTimer = mTim.Enabled
    Enabled = False
End Function
Public Function EnableTimer() As Boolean
    EnableTimer = mTim.Enabled
    Enabled = True
End Function

Public Property Get IntervalSec() As Long
    IntervalSec = mInterval
End Property
Public Property Let IntervalSec(RHS As Long)
    mInterval = RHS
    mModIntMax = mInterval Mod mCMaxI
    mTim.Interval = IIf(mInterval >= mCMaxI, mCMaxI, mInterval) * 1000
End Property

Public Function ToString() As String
    Dim s As String
    s = mTim.Name & ": " & FireKindToString(mFireKind) & " "
    If mFireKind = FireXTimes Then
        s = s & ": " & CStr(mXTime) & " / " & _
                       CStr(mCount - mXTime) & " / " & _
                       CStr(mCount) & "    "
    End If
    ToString = s & Timer
End Function

' #################### ' v  Private Procedures  v  ' #################### '
Private Function FireKindToString(fk As FireKind)
    Select Case fk
    Case FireOnce:      FireKindToString = "FireOnce"
    Case FireXTimes:    FireKindToString = "FireXTimes"
    Case FirePermanent: FireKindToString = "FirePermanent"
    End Select
End Function

Private Function CheckInterval() As Boolean
    Dim diff As Long
    If mInterval <= mCMaxI Then
        CheckInterval = True
    Else
        Call IncIntervals
        diff = mInterval - mIntervals
        If diff = mModIntMax Then
            If mModIntMax = 0 Then 'Null gesondert behandeln
                CheckInterval = True
            Else
                mTim.Interval = mModIntMax * 1000
            End If
        ElseIf diff < mModIntMax Then
            CheckInterval = True
        End If
        If CheckInterval Then
            mIntervals = 0
            mTim.Interval = mCMaxI * 1000
        End If
    End If
End Function
Private Sub IncIntervals()
    mIntervals = mIntervals + mCMaxI
End Sub
Private Sub mTim_Timer()
    'hier wird das Event empfangen und falls die Zeit
    'erreicht ist, wird das Event gleich wieder weitergeworfen
    If CheckInterval Then
        Select Case mFireKind
        Case FireOnce
            mTim.Enabled = False
        Case FireXTimes
            mXTime = mXTime + 1
            If mXTime = mCount Then
                mTim.Enabled = False
            End If
        Case FirePermanent
            'nix machen
        End Select
        RaiseEvent Timer
    End If
End Sub

'Erweiterungen
'=============
'die Klasse ist leicht an eigenen Bedürfnisse anpassbar. So kann man in diese Klasse
'vieles an Funktionalität einprogrammieren, was man schon immer von einem Timer
'erwartet hat, und vom VB.Timer schmerzlich vermisst.
'Denkbare Erweiterungen der Klasse wären:
'* Persistenz
'  ===========
'Um als Intervall mehrere Wochen oder gar Monate zu erreichen, müßte da der Timer
'nicht die ganze Zeit über laufen? Müßte also das Programm und der Computer die ganze
'Zeit über laufen? Das wäre ja nicht sehr praktikabel. Es reicht im Grunde aus, wenn
'der Computer und das Timerprogramm nur kurze Zeit vorher, bevor das Timerereignis
'eintreten soll, gestartet wird. Die Lösung ist, den Timer persistent zu machen, was
'nix anderes heißt, als daß der Timer alle benötigten Daten auf die Festplatte speichert,
'und diese bei Programmstart von dort auch wieder einliest.
'* Termin
'  =======
'Es könnte entweder ein bestimmtes Intervall, oder aber auch ein bestimmter Termin
'eingestellt werden. Dabei ließe sich einstellen, ob der Termin jede Stunde, jeden Tag,
'jede Woche, jeden Monat oder jedes Jahr wiederkehren sollte.

'------- Ende Klasse "LongTimer" alias LongTimer.cls  -------
'--- Anfang Modul "ModConstructors" alias ModConstructors.bas ---
Option Explicit

Public Function New_LongTimer(aTim As VB.Timer, _
                              Optional ByVal aFKind As FireKind = FirePermanent, _
                              Optional ByVal aCount As Long) As LongTimer
    Set New_LongTimer = New LongTimer
    Call New_LongTimer.NewC(aTim, aFKind, aCount)
End Function
'--- Ende Modul "ModConstructors" alias ModConstructors.bas ---
'-------------- Ende Projektdatei Projekt1.vbp --------------