XL 2019 Gérer la descente d'une cellule colorer selon un timer

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Nicolas JACQUIN

Nicolas JACQUIN

XLDnaute Accro
Supporter XLD
Bonjour à toutes et tous,

Je cherche une façon de faire descendre une cellule ligne par ligne à un rytme différent (style tétris) selon valeur en "A1" (valeur pouvant aller de 1 à 15),
mais je n'arrive pas à gérer la vitesse, actuellement si je mets valeur de 1 à 5, pas de différence et si je mets 6 on vois plus rien.

VB: 
Sub DescenteCellule()
    Dim vitesse As Double
    Dim delai As Double
    Dim i As Integer
    Dim couleur As Long

    If IsNumeric(Range("A1").Value) Then
        vitesse = Range("A1").Value
        If vitesse <= 0 Then
            MsgBox "La valeur de A1 doit être supérieure à 0.", vbExclamation
            Exit Sub
        End If
    Else
        MsgBox "Veuillez entrer un nombre valide dans la cellule A1.", vbExclamation
        Exit Sub
    End If

    delai = 1 / (1 + (vitesse - 1) * 0.2)
    couleur = Range("D5").Interior.Color
    Range("D5:D25").Interior.ColorIndex = xlNone

    For i = 5 To 25
        Range("D5:D25").Interior.ColorIndex = xlNone
        Range("D" & i).Interior.Color = couleur
        DoEvents
        Application.Wait Now + TimeSerial(0, 0, delai)
    Next i

    Range("D25").Interior.ColorIndex = xlNone
    Range("D5").Interior.Color = RGB(0, 255, 0) ' Vert
End Sub

Merci à tous.
Nicolas
 

Pièces jointes

Trier par date Trier par votes
Personnellement je suis pas sur , a moins de passe par un userform que tu puisses réduire la vitesse.

Mon timer est a 300 millisecondes et je trouve la descente lente.

La seule façon de réduire la vitesse dans le Tic, car comme dit plus haut.., c'est d'implémenter une variable static dans le Tic qui compte les tours d'horloge et déclanche la descente au bout du cinquième, dixième que sais-je.

Si tu augmentes l'interval du timer tu perds en réactivité des flèches D,G,H,B
 
Vote positif 0 Vote négatif
Si j'ai bien compris,
une proposition pour moduler la vitesse en fonction du niveau sélectionné et de la durée du jeu avec :
- une vitesse initiale identique quelque soit le niveau
- une vitesse qui va augmenter (dans le code toutes les 10 lignes de descentes) avec un incrément (géométrique) en fonction du niveau sélectionné : La vitesse augmente mais de moins en moins rapidement (courbe vitesse/temps en gros logarithmique) .
En reprenant votre code et le Sleep (en coton bio made in France) de Jurassic Pork :
VB: 
Option Explicit
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub DescenteCellule()
    Dim Niveau As Integer
    Dim vitesse As Double
    Dim delai As Double
    Dim i As Integer, j As Double, k As Integer
    Dim NbDescentes As Double
    Dim couleur As Long
    Const DELAI_INITIAL = 100
    Const VITESSE_INITIALE = 1 'quelquesoit le niveau on débute avec la même vitesse
    
    If IsNumeric(Range("A1").Value) Then
        Niveau = Range("A1").Value
        ' niveau de 1 à 10
        If Niveau <= 0 Or Niveau > 10 Then
            MsgBox "La valeur de A1 doit être compris entre 1 et 10.", vbExclamation
            Exit Sub
        End If
    Else
        MsgBox "Veuillez entrer un nombre valide dans la cellule A1.", vbExclamation
        Exit Sub
    End If
    
    NbDescentes = 0
    vitesse = VITESSE_INITIALE
    
    'Boucle k simplement pour simuler 20 séquences de descentes de bloc
    For k = 1 To 20
        couleur = Range("D5").Interior.Color
        Range("D5:D25").Interior.ColorIndex = xlNone
    
        For i = 5 To 25
            Range("D5:D25").Interior.ColorIndex = xlNone
            Range("D" & i).Interior.Color = couleur
            DoEvents
            NbDescentes = NbDescentes + 1
            ' toutes les descentes de 10 lignes (par exemple), on accroit la vitesse (de manière logarithmique)
            If NbDescentes Mod 10 = 0 Then
                ' à chaque fois, la vitesse correspond à la vitesse précédente divisé par 0.999 (niveau 1) 0.99 (niveau 10)
                vitesse = vitesse / (1 - Niveau / 100)
            End If
            Sleep DELAI_INITIAL / vitesse
        Next i
    
        Range("D25").Interior.ColorIndex = xlNone
        Range("D5").Interior.Color = RGB(0, 255, 0) ' Vert
    Next k
    
End Sub
 
Vote positif 0 Vote négatif
crocrocro à dit:
Si j'ai bien compris,
une proposition pour moduler la vitesse en fonction du niveau sélectionné et de la durée du jeu avec :
- une vitesse initiale identique quelque soit le niveau
- une vitesse qui va augmenter (dans le code toutes les 10 lignes de descentes) avec un incrément (géométrique) en fonction du niveau sélectionné : La vitesse augmente mais de moins en moins rapidement (courbe vitesse/temps en gros logarithmique) .
En reprenant votre code et le Sleep (en coton bio made in France) de Jurassic Pork :
VB: 
Option Explicit
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub DescenteCellule()
    Dim Niveau As Integer
    Dim vitesse As Double
    Dim delai As Double
    Dim i As Integer, j As Double, k As Integer
    Dim NbDescentes As Double
    Dim couleur As Long
    Const DELAI_INITIAL = 100
    Const VITESSE_INITIALE = 1 'quelquesoit le niveau on débute avec la même vitesse
  
    If IsNumeric(Range("A1").Value) Then
        Niveau = Range("A1").Value
        ' niveau de 1 à 10
        If Niveau <= 0 Or Niveau > 10 Then
            MsgBox "La valeur de A1 doit être compris entre 1 et 10.", vbExclamation
            Exit Sub
        End If
    Else
        MsgBox "Veuillez entrer un nombre valide dans la cellule A1.", vbExclamation
        Exit Sub
    End If
  
    NbDescentes = 0
    vitesse = VITESSE_INITIALE
  
    'Boucle k simplement pour simuler 20 séquences de descentes de bloc
    For k = 1 To 20
        couleur = Range("D5").Interior.Color
        Range("D5:D25").Interior.ColorIndex = xlNone
  
        For i = 5 To 25
            Range("D5:D25").Interior.ColorIndex = xlNone
            Range("D" & i).Interior.Color = couleur
            DoEvents
            NbDescentes = NbDescentes + 1
            ' toutes les descentes de 10 lignes (par exemple), on accroit la vitesse (de manière logarithmique)
            If NbDescentes Mod 10 = 0 Then
                ' à chaque fois, la vitesse correspond à la vitesse précédente divisé par 0.999 (niveau 1) 0.99 (niveau 10)
                vitesse = vitesse / (1 - Niveau / 100)
            End If
            Sleep DELAI_INITIAL / vitesse
        Next i
  
        Range("D25").Interior.ColorIndex = xlNone
        Range("D5").Interior.Color = RGB(0, 255, 0) ' Vert
    Next k
  
End Sub
Cliquez pour agrandir...

Bonjour @crocrocro ,

merci pour ta proposition, j'en ai eu plusieurs intéressante, comme je disais plus haut,
le but est de commencer avec une chute lente et toute les 10 lignes la vitesse s'accélère progressivement pour tetris,
j'aurai du le stipuler du début, cela aurait été plus simple. Le problème c'est que n'arrive pas à adapter.

Animation2.gif


Merci beaucoup
 

Pièces jointes

Vote positif 0 Vote négatif
Nicolas JACQUIN à dit:
Là par contre moi je travaille avec les touches (flèches) du clavier
Cliquez pour agrandir...
moi également Droite, Gauche, Haut, Bas D,G,H,B
DGHB c'est pas du shit
Excited Jump GIF by MOODMAN

1747756917210.png

par contre je me bas encore avec le scintillement.

j'ai réussi a augmenter la vitesse en jouant sur:
' Désactiver les éléments qui ralentissent l'exécution
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.MoveAfterReturn = False
 

Pièces jointes

Vote positif 0 Vote négatif
dysorthographie à dit:
moi également Droite, Gauche, Haut, Bas D,G,H,B
DGHB c'est pas du shit
Excited Jump GIF by MOODMAN

Regarde la pièce jointe 1218090
par contre je me bas encore avec le scintillement.

j'ai réussi a augmenter la vitesse en jouant sur:
' Désactiver les éléments qui ralentissent l'exécution
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.MoveAfterReturn = False
Cliquez pour agrandir...
Re, voilà ton fichier donne chez moi, ça descend loin loin loin, et scintillement à bloc, et assez rapide

Animation2.gif
 
Vote positif 0 Vote négatif
comme je te l'ai dis c'était un embraillons je n'es pas évalué toutes les combinaisons. l'arrêt dépend de la zone a parcourir en fonction de la forme et des obstacle liés aux autre formes.

vue le scintillement je ne suis plus convaincu qu'il faille persévérer sur ce chemin!

mais je vois que tu es bien entouré et que tua quand même fait un sacré beau travail
1747760456168.png
 
Dernière édition:
Vote positif 0 Vote négatif
Rheeem à dit:
Le déplacement des shapes est plus fluide que le dessin direct sur la feuille et produit moins de scintillement
Cliquez pour agrandir...
Hello,
la remarque de Rheeem est judicieuse, c'est une piste à explorer pour améliorer le jeu. Surtout que l'on peut faire des rotations sur des formes.
Le seul souci c'est qu'il faut fabriquer toutes les formes possibles pour le tétris. Pour commencer tester avec une forme pour voir ce que cela change. On peut aussi utiliser une forme de base et constituer toutes les formes en groupant des objets dupliqués à partir de cette forme de base :
blocTetris.png


[EDIT] voilà ce que cela donne avec ce code :
VB: 
Sub TestForme()
    Application.OnKey "{LEFT}", "DeplacerDroiteF"
    Application.OnKey "{RIGHT}", "DeplacerGaucheF"
    Application.OnKey "{DOWN}", "DescendreF"
    Application.OnKey "{UP}", "TournerF"
End Sub

Sub DeplacerGaucheF()
    ActiveSheet.Shapes("Tetris1").IncrementLeft 50
End Sub

Sub DeplacerDroiteF()
     ActiveSheet.Shapes("Tetris1").IncrementLeft -50
End Sub

Sub DescendreF()
     ActiveSheet.Shapes("Tetris1").IncrementTop 50
End Sub
Sub TournerF()
     ActiveSheet.Shapes("Tetris1").IncrementRotation 90
End Sub

tetrisForme.gif

Ami calmant, J.P
 
Dernière édition:
Vote positif 0 Vote négatif
Bonjour à tous,

@Rheeem et @jurassic pork , merci de votre retour,
Oui l'idée est pas mauvaise, il n'y a que 7 formes à créer, ( I , O , T , S , Z , L , J ) mais la n'est pas ma difficulté.

VB: 
    ' Définition des cellules des formes
    ListeFormes(0).Cells = Array(Array(0, 0), Array(1, 0), Array(2, 0), Array(3, 0)) ' I
    ListeFormes(1).Cells = Array(Array(0, 0), Array(0, 1), Array(1, 0), Array(1, 1)) ' O
    ListeFormes(2).Cells = Array(Array(0, 1), Array(1, 0), Array(1, 1), Array(1, 2)) ' T
    ListeFormes(3).Cells = Array(Array(0, 1), Array(0, 2), Array(1, 0), Array(1, 1)) ' S
    ListeFormes(4).Cells = Array(Array(0, 0), Array(0, 1), Array(1, 1), Array(1, 2)) ' Z
    ListeFormes(5).Cells = Array(Array(0, 0), Array(1, 0), Array(2, 0), Array(2, 1)) ' L
    ListeFormes(6).Cells = Array(Array(0, 1), Array(1, 1), Array(2, 1), Array(2, 0)) ' J

Ma base ( #38 ) est peux être pas votre meilleur choix, mais je n'est pas de scintillement, ma seule difficulté c'est de gérer la vitesse de descente des pièces selon le niveaux actuel en fonction du score, sinon le reste est fonctionnel.

Merci
Nicolas
 
Vote positif 0 Vote négatif
Nicolas JACQUIN à dit:
ma seule difficulté c'est de gérer la vitesse de descente des pièces selon le niveaux actuel en fonction du score, sinon le reste est fonctionnel.
Cliquez pour agrandir...
VB: 
Sub Animation()
  Dim x As Integer
  Dim debtempor As Integer, tempor As Integer, niveau As Integer
  For niveau = 1 To 3
      debtempor = 1000 / niveau
      tempor = debtempor
      For x = 0 To 15
          If x = 5 Then tempor = tempor / 2
          If x = 10 Then tempor = tempor / 3
          DescendreF
          DoEvents
          Tempo tempor
      Next x
      Remonter x
  Next niveau
End Sub

AnimationTetris.gif


[EDIT] Les Application.OnKey ne semble pas fonctionner quand on fait une boucle pour la descente. Par contre cela fonctionne avec des Application.OnTime qui générent des événements. Pour avoir une résolution d'événements inférieure à la seconde utiliser un timer comme le fait Bob
 
Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

A
  • Résolu(e)
XL 2019 Remplacer un mot et ajouter une couleur
Réponses
7
Affichages
182
Attila451
A
A
  • Question Question
XL 2019 Copie d'une valeur dans la cellule à côté d'une valeur trouvé
Réponses
1
Affichages
78
sylvanu
sylvanu
G
  • Question Question
XL 2016 # MFC applicable selon valeur autre cellule Vba
Réponses
9
Affichages
539
TooFatBoy
TooFatBoy
T
  • Résolu(e)
Microsoft 365 VBA Exporter une sélection de plages nommées au format PDF
Réponses
12
Affichages
198
tnion
T
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
284
patricktoulon
patricktoulon
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
385
CortoXls
C
P
  • Résolu(e)
Microsoft 365 Macro qui change l'épaisseur du contour d'une forme
Réponses
11
Affichages
573
pat66
P
klin89
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
436
patricktoulon
patricktoulon
pascal21
  • Question Question
Microsoft 365 selectionner cellule via un combobox
Réponses
3
Affichages
90
job75
job75
A
  • Question Question
insertion d'une ligne automatique dans un tableau excel.
Réponses
1
Affichages
371
sylvanu
sylvanu
C
  • Question Question
XL 2016 VBA - Mettre en Indice une partie du contenu d'une cellule : problème avec la propriété Font.Subscript
Réponses
2
Affichages
146
crocrocro
C
S
  • Question Question
Microsoft 365 Colorer automatiquement des cellules en les sélectionnant
Réponses
5
Affichages
537
Jacky67
Jacky67
H
  • Résolu(e)
XL 2016 Copier cellule dans un autre onglets
2
Réponses
16
Affichages
490
Phil69970
Phil69970
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
496
Gestionnaire_rh
G
S
  • Question Question
XL 2013 enregistrer une feuille excel converti en pdf dans un répertoire selon la valeur d'une cellule
Réponses
5
Affichages
270
Phil69970
Phil69970
piga25
  • Résolu(e)
XL 2016 En VBA, Automatiser la réponse en fonction de l'état d'une cellule.
Réponses
7
Affichages
155
piga25
piga25
piga25
  • Résolu(e)
XL 2016 Mettre la même couleur de la dernière cellule colorée
Réponses
5
Affichages
393
TooFatBoy
TooFatBoy
Jojo973
  • Question Question
Microsoft 365 Trouver et attribuer une plage de cellule en fonction de la cellule active
Réponses
6
Affichages
465
Jojo973
Jojo973
A
  • Question Question
XL 2016 Macro et rajout d'un chiffre au nom d'un Shape
Réponses
9
Affichages
661
alain.raphael
A
D
  • Question Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
703
dadu35
D
Retour