Tipp 0084 CountDown
Autor/Einsender:
Datum:
  Ronald Janowski
15.06.2001
Entwicklungsumgebung:   VB 6
Dieser grafisch sehr gut gelungene Tipp ist schon fast ein kleines Projekt. Er zeigt ausführlich wie man mit Zeiten arbeiten kann. Er ist sowohl als Stoppuhr wie auch als Wecker einsetzbar. Eine eingestellte Zeit wird bis auf Null gezählt, oder der Wecker meldet sich, wenn eine eingestellte Zeit erreicht wurde.
Als besonderen Leckerbissen hat der Autor dem Tipp einen selbst erstellten Digital-Font beigefügt.
Code im Codebereich des Moduls
 
Option Explicit

Public Declare Function ReleaseCapture Lib "user32" () As Long

Public Declare Function SendMessagelong Lib "user32" Alias _
      "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
      ByVal wParam As Long, ByVal lParam As Long) As Long

Public Const WM_NClBUTTONDOWN = &HA1
Public Const HTCAPTION = 2
 
Code im Codebereich der Form
 
ption Explicit

Dim setHour As Integer, setMinute As Integer
Dim cHour, cMin, cSec
Dim cTime As String, wavName As String
Dim getTime As Date
Dim Sound As Boolean

Private Sub chkSound_Click()
  If chkSound.Value = 0 Then
    Sound = False
  Else
    Sound = True
  End If
End Sub

Private Sub cmdSet_Click()
  'Eingabe prüfen
  If Not txtHour.Text = "" And Not txtMinute.Text = "" _
        And Not txtSekunde.Text = "" Then
    If Not Len(txtHour.Text) < 2 And Not Len(txtMinute.Text) < 2 _
          And Not Len(txtSekunde.Text) < 2 Then

      'Wenn SetTime
      If optSetTime = True Then
        getTime = Format(Time, "hh:mm:ss")
        setHour = Format(txtHour.Text, "00")
        setMinute = Format(txtMinute.Text, "00")

        'Berechnen der Stunden
        cHour = setHour
        If setHour < Mid$(getTime, 1, 2) Then
          cHour = 24 - (Mid$(getTime, 1, 2) - setHour)
        ElseIf setHour = Mid$(getTime, 1, 2) Then
          If setMinute < Mid$(getTime, 4, 2) Then
            cHour = 23
          ElseIf setMinute > Mid$(getTime, 4, 2) Then
            cHour = 0
            cHour = Format(cHour, "00")
          ElseIf setMinute = Mid$(getTime, 4, 2) Then
            cHour = 23
          End If
        Else
          cHour = setHour - Mid$(getTime, 1, 2)
          cHour = Format(cHour, "00")
        End If

        'Berechnen der Minuten
        cMin = setMinute
        If setMinute < Mid$(getTime, 4, 2) Then
          cMin = 60 - (Mid$(getTime, 4, 2) - setMinute)
          If Not setHour = Mid$(getTime, 1, 2) Then
            cHour = Format(cHour - 1, "00")
            cMin = Format(cMin - 1, "00")
          Else
            cMin = Format(cMin - 1, "00")
          End If
        ElseIf setMinute = Mid$(getTime, 4, 2) Then
          If setHour = Mid$(getTime, 1, 2) Then
            cMin = 59
          Else
            cMin = 0
            cMin = Format(cMin, "00")
          End If
        Else
          cMin = setMinute - Mid$(getTime, 4, 2)
          cMin = Format(cMin - 1, "00")
        End If

        'Sekunden festlegen im SetTime-Modus
        cSec = 60 - Format(Now, "ss")

      'Wenn SetCount
      ElseIf optSetCount = True Then
        cHour = Format(txtHour.Text, "00")
        cMin = Format(txtMinute.Text, "00")
        cSec = Format(txtSekunde.Text, "00")
      End If

      'Voreinstellung
      tmrCountDown.Enabled = True: cmdSet.Enabled = False
        txtHour.Locked = True: txtMinute.Locked = True: _
              txtSekunde.Locked = True
          wavName = App.Path & "\tick.wav"

    'Wenn fehler bei Eingabe
    Else
     MsgBox "Bitte geben Sie auch die führenden Nullen mit an !" _
         & vbCrLf & vbCrLf & vbCrLf & " Beispiel :" & vbCrLf _
         & vbCrLf & "  Richtig = 08 : 15,   Falsch  =  8 : 15", _
         vbExclamation, "Falsche Eingabe"
   End If
   'Wenn Eingabefeld leer
  Else
    MsgBox "Bitte füllen Sie alle Felder aus !", vbExclamation, _
           "Fehlende Eingabe"
  End If
End Sub

Private Sub cmdStop_Click()
  cHour = 0: cMin = 0: cSec = 0: cTime = "": setHour = 0: _
        setMinute = 0
  txtHour.Locked = False: txtMinute.Locked = False: _
        txtSekunde.Locked = False
  tmrCountDown.Enabled = False: cmdSet.Enabled = True
End Sub

Private Sub Form_load()
  lblDate.Caption = Format(Date, "dd.mm.yyyy"): Sound = True
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
      X As Single, Y As Single)
  If Button = 1 Then
    ReleaseCapture
    SendMessagelong Me.hWnd, WM_NClBUTTONDOWN, HTCAPTION, 0
  End If
End Sub

Private Sub optSetCount_Click()
  txtSekunde.Enabled = True
End Sub

Private Sub optSetTime_Click()
  txtSekunde.Enabled = False
End Sub

Private Sub tmrTime_Timer()
  lblCurrentTimeShow.Caption = Format$(Now, "hh:mm:ss")
End Sub

Private Sub tmrCountDown_Timer()
  'Wenn Sound an
  If Sound = True Then
      MMC1.FileName = wavName
      MMC1.Wait = False
      MMC1.Command = "Sound"
  End If

  'Countdown anzeigen
  cTime = Format$(cHour, "00:"): cTime = cTime & _
      Format$(cMin, "00:"): cTime = cTime & Format$(cSec, "00")
  lblHaveTime.Caption = cTime

  'Anpassen der Sekunden alle 20 Sekunden wenn SetTime = True
  If optSetTime = True Then
    If cSec / 5 = 2 Xor cSec / 10 = 3 Xor cSec / 10 = 5 Then
      cSec = 60 - Format(Now, "ss")
    End If
  End If

  'Countdown runterzählen
  cSec = cSec - 1
  If cSec = -1 Then
    cSec = 59
    cMin = cMin - 1
    If cMin = -1 Then
      If Not cHour = 0 Then
        cMin = 59
        cHour = cHour - 1
      End If
    End If
  End If

  'Auswerten der Countdownzeit
  If lblHaveTime.Caption = "00:00:00" Then
    MMC1.FileName = App.Path & "\thx.wav"
    MMC1.Wait = False
    MMC1.Command = "Sound"
    tmrCountDown.Enabled = False: cmdSet.Enabled = True
    txtHour.Locked = False: txtMinute.Locked = False: _
        txtSekunde.Locked = False
  End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  MMC1.Command = "Close"
End Sub

Private Sub txtHour_KeyPress(KeyAscii As Integer)
  Call crtlKey(KeyAscii)
End Sub

Private Sub txtMinute_KeyPress(KeyAscii As Integer)
  Call crtlKey(KeyAscii)
End Sub

Private Sub txtSekunde_KeyPress(KeyAscii As Integer)
  Call crtlKey(KeyAscii)
End Sub

Private Function crtlKey(cKey As Integer)
  Select Case cKey
    Case 48 To 57
    Case 8
  Case Else
    cKey = 0
  End Select
End Function

Private Sub cmdExit_Click()
  tmrTime.Enabled = False: tmrCountDown.Enabled = False: _
      Unload Me
End Sub
 
Weitere Links zum Thema
Exakte Zeitmessung

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (31,5 kB) Downloads bisher: [ 7036 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Samstag, 20. August 2011