Test på tid i Excel2000

Dette i et modul, alt startes med makroen start

Public Sluttid As Date

Public Sub Start()
Sluttid = Now() + TimeSerial(0, 30, 0) ' 30 minutter
Application.OnTime TimeValue(Sluttid), "StopTid"
Application.OnTime TimeValue(Now()), "VisTid"
Resterendetid.Show
End Sub

Public Sub StopTid()
MsgBox " Tiden er nu udløbet"
End Sub

Public Sub VisTid()
Resterendetid.Tid.Caption = Format((Sluttid - Now), "nn:ss")
Application.OnTime TimeValue(Now() + TimeSerial(0, 0, 10)), "VisTid" ' opdateres hvert 10 sek.
End Sub




Dette i en userform ved navn 'Resterendetid'.
Den består af en etiket ved navn 'Tid'
Modal sættes til false

Private Sub UserForm_Initialize()
Tid.Caption = Format(Sluttid - Now, "nn:ss")

End Sub

Ny, jeg havde glemt at ontime procedurer også skal stoppes. ;-))

Dette i et modul, alt startes med makroen StartTid


Public Sluttid As Date
Public StopUr As Date
Public Omstart As Date

Public Sub StartTid()
If Omstart <> 0 Then ' stopper forrige start, hvis den ikke er afsluttet
Application.OnTime EarliestTime:=(Omstart), Procedure:="Stoptid", Schedule:=False 'stopper tids visningen
Resterendetid.Hide
End If
Sluttid = Now() + TimeSerial(0, 30, 0) ' 30 minutter
Omstart = Sluttid
Application.OnTime TimeValue(Sluttid), "StopTid"
Resterendetid.Show
VisTid
End Sub

Public Sub Stoptid()
MsgBox " Tiden er nu udløbet"
Application.OnTime EarliestTime:=(StopUr), Procedure:="VisTid", Schedule:=False 'stopper tids visningen
Resterendetid.Hide
End Sub

Public Sub VisTid()
StopUr = Now() + TimeSerial(0, 0, 10) ' opdaterer uret hvert 10 sek.
Resterendetid.Tid.Caption = Format((Sluttid - Now), "nn:ss")
Application.OnTime TimeValue(StopUr), "VisTid"
End Sub


Derudover en userform ved navn 'Resterendetid'.
Den består af en etiket ved navn 'Tid'
Modal sættes til false

ingen kode i userformen

marker mit navn og tryk accepter