Microsoft 365 compte à rebours avec application.OnTime (Résolu)

[xabino]

Bonjour,

J'ai fait un décompte dans le but de faire un "Défi multiplication" pour mes enfants.
Le problème, c'est que le décompte va 2 fois trop vite et je n'arrive pas à comprendre pourquoi.

Ci dessous le code utilisé.

Option Explicit
Public chrono As Range

Sub lancer_chrono()
'LECTURE
    Application.OnTime Now + TimeValue("00:00:01"), "decompte"

End Sub

Sub decompte()

Set chrono = Range("B10").MergeArea
'decompte
If Sheets("générateur de multiplication").Range("B20") = 0 Then
chrono.Font.Color = RGB(0, 0, 0)
chrono.Interior.Color = RGB(255, 255, 255)
Sheets("générateur de multiplication").Range("B20").Value = "00:00:00"
Unload UserForm2
UserForm2.Show
Exit Sub
End If

Sheets("générateur de multiplication").Range("B20").Value = Sheets("générateur de multiplication").Range("B20").Value - TimeValue("00:00:01")

If Sheets("générateur de multiplication").Range("B20").Value = TimeValue("00:00:10") Then
        chrono.Interior.Color = RGB(204, 51, 51)
        chrono.Font.Color = RGB(0, 0, 0)
End If

lancer_chrono

End Sub

Je vous joint également le fichier sur lequel le code est présent.

Merci d'avance

 

[nullosse]

Salut,
le souci avec le Application.Ontime c'est qu'il n'est pas précis et aussi que le VBA est bloqué par exemple quand on édite une cellule dans une feuille. Ton décompteur est arrêté et ne reprend que quand on n'édite plus la cellule. Je te propose du code (à adapter pour ton cas) qui utilise le temps système pour décompter mais à base quand même de Application.Ontime. Quand le décompteur est bloqué par exemple par l'édition d'une cellule quand on n'édite plus la cellule, la valeur du décompteur correspond bien au temps écoulé. Voici le code :

Option Explicit

Dim NextTick As Date
Dim EndTime As Date
Dim Running As Boolean

' Lancer un décompte de N secondes
Sub StartCountdown(ByVal Seconds As Long)
    EndTime = Now + TimeSerial(0, 0, Seconds)
    Running = True
    ScheduleNextTick
End Sub

' Planifier le prochain tick
Private Sub ScheduleNextTick()
    If Not Running Then Exit Sub
    NextTick = Now + TimeSerial(0, 0, 1)
    Application.OnTime NextTick, "CountdownTick"
End Sub

' Tick : met à jour la cellule A1
Sub CountdownTick()
    Dim remaining As Long
    remaining = DateDiff("s", Now, EndTime)

    If remaining <= 0 Then
        Feuil2.Range("A1").Value = "Terminé !"
        Running = False
    Else
        Feuil2.Range("A1").Value = remaining & " s restantes"
        ScheduleNextTick
    End If
End Sub

' Arrêter proprement le décompte
Sub StopCountdown()
    On Error Resume Next
    Application.OnTime NextTick, "CountdownTick", , False
    Running = False
End Sub

Sub GoChrono()
  StartCountdown 30
End Sub

Et voici ce que cela donne :

Nullosse

 

[nullosse]

J'ai trouvé pourquoi tu avais un souci dans ton décomptage : tu lances 2 fois lance_chrono : dans userform1 et dans userform3

 

[xabino]

Merci beaucoup pour cette réponse.
J'ai réussi à adapter une bonne partie.
J'ai également ajouté des lignes pour convertir les secondes au bon format (hh:mm:ss).
Par contre, j'ai toujours un bug dans les 10 dernières seconde même si le chrono continu.
Est-ce que cela pourrait venir de ma fonction HMS?

Merci d'avance

 

[nullosse]

Je ne sais pas si tu as le même phénomène ,que moi mais dans le décompte par moment il ne se rafraichit pas pendant quelque secondes ( 5 secondes par exemple) si bien que le décompte fait un saut de 5 secondes. C'est comme si le Application.Ontime était bloqué pendant ces 5 secondes.
Est-ce que tu as ce phénomène ? Moi je suis sous Excel 2021 64 bits

 

[xabino]

Je ne sais pas si tu as le même phénomène ,que moi mais dans le décompte par moment il ne se rafraichit pas pendant quelque secondes ( 5 secondes par exemple) si bien que le décompte fait un saut de 5 secondes. C'est comme si le Application.Ontime était bloqué pendant ces 5 secondes.
Est-ce que tu as ce phénomène ? Moi je suis sous Excel 2021 64 bits

oui, c'est exactement le même phénomène. Moi je tourne sur excel365 64Bit
mais j'ai vérifié en mettant la fonction HMS en commentaire, ainsi que ces appels et le phénomène survient toujours, elle n'est donc pas fautive.

 

[nullosse]

Bon j'ai fait un programme tout simple :

Dim Tps As Date
Dim Compteur As Long

Sub LancerChronometre()
    Compteur = 0
    Tps = Now + TimeValue("00:00:01")  ' Planifier l'exécution dans 1 seconde
    Application.OnTime Tps, "MajChronometre"
End Sub

Sub MajChronometre()
    Compteur = Compteur + 1
    Debug.Print "Temps écoulé : " & Compteur & " secondes"
  
    ' Planifier la prochaine exécution dans 1 seconde
    Tps = Now + TimeValue("00:00:01")
    Application.OnTime Tps, "MajChronometre"
End Sub

ben là aussi ça bloque par moment pendant plusieurs secondes et je ne fait rien dans le classeur . Bug sur application.Ontime ? cela dépend-t-il de la version d'Excel ?

 

[xabino]

Je ne sais pas, c'est possible.
En tout cas merci pour ton aide.
Je considère mon problème résolu.

 

[nullosse]

En pièce jointe un classeur qui utilise les API Timer plutôt que le Application.Ontime

 

[xabino]

En pièce jointe un classeur qui utilise les API Timer plutôt que le Application.Ontime

merci, j'y jetterai un coup d'œil dès que j'aurai une petite heure