XL 2021 Colorer avec condition de temps

[matlatarte]

Bonjour,

j'aimerai colorer un objet ou autre chose de manière conditionnée au temps:
lorsque je clique sur une macro/bouton j'aimerai qu'un objet soit rouge par exemple de 5 à 6 s (pdt 1s donc) après avoir cliqué sur le bouton et ensuite qu'il redevienne comme avant.

la condition 5 à 6 seconde sera variable en fct d'une valeur de cellule (des fois de 0 à 2s, des fois de 10s à 30s ect..)

Je ne vois pas comment m'y prendre ? Est ce possible ?

Merci de votre aide !

 

[matlatarte]

Sub jouesisterACT() 'le dernier argument pour asyncro ou syncro
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"

Dim MonWav As String
MonWav = Range("AB32").Value '... chemin et nom à adapter
ExecuteExcel4Macro ("CALL(""winmm"",""PlaySoundA"",""JCJJ"",""" & MonWav & """, " & 0 & "," & &H1 & ")")



End Sub

à la suite ? J'ai essayé de placer la macro "couleur" avant ou après la macro "son", cela n'a pas l'air de changer grand chose

 

[jurassic pork]

Question bête : Pourquoi tu n'utilises Powerpoint ? Cela semble plus adapté à ce que tu veux faire.

 

[matlatarte]

J'ai des calculs complexes et des graphes à gogo dans le même projet...

 

[jurassic pork]

Au lieu d'utiliser PlaySound pour jouer l'audio tu peux utiliser l'objet windows media player et en plus tu pourrais jouer des mp3. J'ai fait un essai cela à l'air de fonctionner.

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

 

[matlatarte]

Au lieu d'utiliser PlaySound pour jouer l'audio tu peux utiliser l'objet windows media player et en plus tu pourrais jouer des mp3. J'ai fait un essai cela à l'air de fonctionner.

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

Rectification: ca marche mais toujours un décalage aléatoire meme avec cette formule:

WindowsMediaPlayer1.currentPlaylist.Clear
Set Xwmp = WindowsMediaPlayer1.newMedia(Range("AB32").Value)
WindowsMediaPlayer1.currentPlaylist.insertItem 0, Xwmp
WindowsMediaPlayer1.settings.setMode "loop", False
WindowsMediaPlayer1.Controls.PLAY

Je pense que cela nevient pas d'un décalage de son mais un décalage de temp sur le changement de couleur: je pense que le "NOW" prend à la seconde près et du coup suivant le moment ou je clique cela peut être à 10h15m15.9seconde ou 10h15m15.1seconde et il prend 15seconde dans tous les cas.
Pour la précision de mon fichier son qui lui démarre toujours à 0seconde je pense que cela vient de là (mon décalage est au pire d'une seconde jamais plus)

Je ne vois pas d'autre raison ni de solution...

 

[matlatarte]

J'en reviens à la remarque du début: il faudrait une fonction "time" qui soit précise au moins au 10ème de seconde pour que cela ne se ressente plus mais à priori cela n'existe pas

à moins que la solution de silvanu soit modifiable pour être plus précise qu'à la seconde ?

VB:
Sub changementcouleurauclicpdtsecondes()
Temps = Int([G13] - [G12])
ActiveSheet.Shapes("Image 3").Fill.ForeColor.RGB = RGB(255, 0, 0)
Application.ScreenUpdating = True
Application.Wait Time + TimeSerial(0, 0, Temps)
ActiveSheet.Shapes("Image 3").Fill.ForeColor.RGB = RGB(255, 255, 255)
End Sub

Le temps sera un entier de secondes, sinon il faut modifier le code. ?

 

[Dranreb]

Il n'est pas possible de planifier une action unique à moins d'une seconde près. Mais il est possible d'exécuter périodiquement une action plus fréquemment, et d'y connaitre l'heure à quelques centaines de nanosecondes près en utilisant QueryPerformanceCounter et QueryPerformanceFrequency.
Mon objet Rythmeur permet de le faire dans un module objet. Je joins un autre classeur à étudier.

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

 

[jurassic pork]

Hello,

Mon objet Rythmeur permet de le faire dans un module objet. Je joins un autre classeur à étudier.

J'ai étudié ton classeur et ton merveilleux objet Rythmeur et j'ai réussi à créer un module de classe appelé Sequenceur basé sur ton rythmeur et qui génère des événements qui peuvent être exploité dans une feuille ou un UserForm
voici le code du module de classe :

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

Il y a 3 événements :
evDepart qui est déclenché quand le temps de départ est atteint
evFin Quand il est temps d'arrêter la séquence
evChrono à chaque fois avec comme fréquence Précision . Par exemple avec une précision de 10 , il est
déclenché toutes les 100 ms.
Il y a un Timeout qui est le temps à ne pas dépasser par le Timer sinon on l'arrête .
Et voici comme on l'exploite par exemple dans une feuille :

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

En pièce jointe un zip contenant le classeur de démo et un fichier audio midi.
Attention ne pas faire n'importe quoi car l'Api Timer peut faire planter Excel. Bien Sauvegarder avant de lancer.
[EDIT] je viens de tester sous Excel 2021 64 bits, il y avait un souci : Bien compiler le code avant de lancer le séquenceur pour voir si il n'y a pas d'erreur. Corriger les erreurs avant de lancer les macros sinon çà peut planter Excel (le timer est lancé et on est arrêté dans le code).

AMi calmant, J.P

 

[matlatarte]

bug Erreur Compilation element introuvable

RaiseEvent EvFin

 

[jurassic pork]

bug Erreur Compilation element introuvable

RaiseEvent EvFin

Oui c'est l'erreur que j'ai eu . Je remet en pièce jointe le classeur que j'ai corrigé avec mon Excel 64 bits.

 

[matlatarte]

j'ai toujours la même erreur j'ai Excel 2021 pro...

 

[jurassic pork]

Ben moi aussi j'ai Excel 2021 mais pas pro.
Ce que j'avais fait supprimer les chaines avec EvFin dans le code et les recréer Dans le module Sequenceur dès fois qu'il y ait un caractère invisible. Ou bien renommer l'événement EvFin en EvTerm dans le code du module de classe Sequenceur et dans la Feuille ( Private Sub Seq_EvTerm() )

 

[matlatarte]

renommé en EvTerm et ca roule ! et effectivement tout reste synchro !! BRAVO !


merci