XL 2021 Colorer avec condition de temps

Option Explicit
Public wmp As Object

Sub JouerSon()
   Set wmp = CreateObject("new:WMPlayer.OCX.7")
   wmp.Url = "d:\temp\OhHappyDay.mp3"
   wmp.Controls.Play
End Sub

Sub ArretSon()
 wmp.Controls.Stop
 Set wmp = Nothing
End Sub

Sub jouesisterACT() 
Dim RunTime As Date, Start, Fin, DelayTime
Start = Range("AG31").Value
DelayTime = Range("AH31").Value
Fin = Start + DelayTime
RunTime = Now + TimeValue("00:00:" & Start)
Application.OnTime RunTime, "MaMacroDeb"
RunTime = Now + TimeValue("00:00:" & Fin)
Application.OnTime RunTime, "MaMacroFin"
JouerSon
End Sub

Sub MaMacroDeb()
ActiveSheet.Shapes("Image 3").Fill.ForeColor.RGB = RGB(255, 0, 0)
End Sub
Sub MaMacroFin()
ActiveSheet.Shapes("Image 3").Fill.ForeColor.RGB = RGB(255, 255, 255)
End Sub

Option Explicit
                        #If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
                        #Else
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
                           #End If
Private CTrMinuit As Currency, CtrUnJour As Currency
Function HeurePrécise() As Double
   Dim CtrMaintenant As Currency, X As Single, TmrSynchro As Single, CtrSynchro As Currency, F As Currency
   QueryPerformanceCounter CtrMaintenant
   If CtrUnJour = 0 Then
      X = Timer: Do: TmrSynchro = Timer: Loop Until TmrSynchro <> X: QueryPerformanceCounter CtrSynchro
      QueryPerformanceFrequency F: CTrMinuit = CtrSynchro - F * TmrSynchro: CtrUnJour = F * 86400: End If
   HeurePrécise = (CtrMaintenant - CTrMinuit) / CtrUnJour
   End Function

Option Explicit
'J.P Novembre 2024
#If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
#Else
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
#End If
Public Event EvFin()
Public Event EvDepart()
Public Event EvChrono(ByVal Temps As Double)
Private WithEvents Ryth As Rythmeur, Dep As Double, Fin As Double, TimeOut As Double, Freq As Long
Private Fréq As Currency, CycBase As Currency, Cyc As Currency, CycCum As Currency, Temps As Double
Private BDepart As Boolean, BFin As Boolean
Private Sub Class_Initialize()
   QueryPerformanceCounter CycBase: QueryPerformanceFrequency Fréq
   Set Ryth = New Rythmeur
   End Sub
Public Sub Init(ByVal TempsDépart As Double, ByVal Durée As Double, _
                ByVal Précision As Integer, ByVal Limite As Double)
   Freq = Précision
   Dep = TempsDépart
   Fin = TempsDépart + Durée
   TimeOut = Limite
   QueryPerformanceCounter Cyc: If Lancé Then Exit Sub
   If Cyc - CycCum - CycBase > Freq / 10000@ Then CycBase = Cyc - CycCum
   BDepart = False: BFin = False
   Ryth.Lancer Freq
   End Sub
Private Sub Ryth_Intervient(ByVal Tic As Long)
   On Error Resume Next
   QueryPerformanceCounter Cyc: CycCum = Cyc - CycBase
   Temps = CycCum / Fréq + 0.05: RaiseEvent EvChrono(Temps)
   If Temps > Dep And Not BDepart Then
      BDepart = True
      RaiseEvent EvDepart
   End If
   If Temps > Fin And Not BFin Then
            RaiseEvent EvFin
            BFin = True
            Ryth.Stopper
   End If
   If Temps > TimeOut Then
       Ryth.Stopper
       Set Ryth = Nothing
       Debug.Print "TimeOut"
   End If
   End Sub
Public Sub Stopper()
  Ryth.Stopper
End Sub
Public Function Lancé() As Boolean
Rem. ——— Propriété en lecture seule. Indique si le chronomètre est lancé.
   Lancé = Ryth.Lancé
   End Function

Option Explicit
Private WithEvents Seq As Sequenceur
Sub LanceSequenceur()
   Set Seq = New Sequenceur
   Seq.Init Range("TempsDépart"), Range("Durée"), _
            Range("Précision"), Range("Limite")
   JouerSon Range("FicAudio")
End Sub

Private Sub Seq_EvDepart()
      Debug.Print "Start"
      Shapes("Image 3").Fill.ForeColor.RGB = RGB(255, 0, 0)
End Sub

Private Sub Seq_EvFin()
      Debug.Print "Fin"
      Shapes("Image 3").Fill.ForeColor.RGB = RGB(255, 255, 255)
End Sub
Private Sub Seq_EvChrono(ByVal Temps As Double)
      Range("Chrono").Value = Temps
End Sub

Private Sub CommandButton1_Click()
  LanceSequenceur
End Sub

Private Sub CommandButton2_Click()
  Seq.Stopper
  Set Seq = Nothing
End Sub

Private Sub CommandButton3_Click()
  ArretSon
End Sub