Logo Hardware.com.br
Jonhny68
Jonhny68 Novo Membro Registrado
1 Mensagem 0 Curtidas

Cronometro regressivo

#1 Por Jonhny68 22/05/2015 - 14:16
Adaptei um cronometro regressivo e adaptei ao que pretendo. É para ser usado numa prova de ciclismo e numa etapa de contra-relogio em que os ciclistas partem de 2 em 2 minutos. Ele funciona mas não consigo fazer o loop para que quando chega a zero (00:00:00), lança na folha a hora da partida e volta iniciar com o tempo selecionado na combobox1, que por sua vez tem varias hipóteses de escolha, mas uma vez escolhido é sempre o mesmo.
Outra coisa que gostaria que fizesse era quando falta-se 5 segundos para o fim e a cada segundo emitisse um som . Junto o código no form e no modulo.
Se alguém me puder ajudar desde já agradeço!

No form

Option Explicit
Dim T
Private Sub ComboBox1_Change()
TextBox1.Value = ComboBox1.Value
End Sub
Private Sub CommandButton1_Click()
T = Time
'Definir qde de tempo a regredir
If RegressivoForm3.ComboBox1.Value = "00:00:10" Then
Fim = Time + TimeValue("00:00:10")
End If
If RegressivoForm3.ComboBox1.Value = "00:00:15" Then
Fim = Time + TimeValue("00:00:15")
End If

Application.Run "StartTimer"
End Sub
Private Sub CommandButton2_Click()
'Para que se carregar no parar com o crono parado não dar erro
On Error Resume Next
'Para o crono
Application.OnTime Now + TimeValue("00:00:01"), "Update", , False
End Sub
Private Sub CommandButton3_Click()
TextBox1.Value = ComboBox1.Value
End Sub
Private Sub UserForm_Initialize()
With ComboBox1
.AddItem "00:00:10"
.AddItem "00:00:15"
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
StopTimer
End Sub

No modulo

Option Explicit
Dim T
Public Fim As Date, Num As Long, ComboBox1 As Long
Sub StopTimer()
'Encerra a cronometragem
On Error Resume Next
Application.OnTime T, Procedure:="Update", Schedule:=False
End Sub
Sub StartTimer()
'Verifica diferença dos segundos
If Time < Fim Then
'Atualiza a cada 1 segundo
Application.OnTime Now + TimeValue("00:00:01"), "Update"

Else
'Chama rotina para encerrar contagem
Application.Run "StopTimer"
'Quando chega aos 5 seg muda a cor para vermelho


'Verifica se o dorsal já partiu
If Range("D" & (ActiveCell.Row)).Value <> "" Then
MsgBox "Este dorsal ja iniciou a etapa!", vbCritical, "Erro"""
RegressivoForm3.TextBox2.SetFocus
End If

If Range("D" & (ActiveCell.Row)).Value = "" Then
'Seleciona a celula e poe o tempo
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = Time
'Seleciona a linha e poe cor verde
Range("A" & (ActiveCell.Row), Selection.End(xlToLeft).Offset(0, 3)).Select
With Selection
.Interior.ColorIndex = 4
End With
End If
End If

End Sub
Sub Update()

RegressivoForm3.TextBox1 = Format(Fim - Time, "hh:mm:ss")

Call StartTimer

End Sub

Sub meuform()
RegressivoForm3.Show
End Sub
© 1999-2024 Hardware.com.br. Todos os direitos reservados.
Imagem do Modal