Mouvement d'un dé dans un UserForm

Signaler
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
-
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
-
Bonjour,

J'essaie de rendre "réaliste" (on s'entend bien, ça n'est que du VBA...), le jet de dé et son déplacement au sein d'un UserForm.

Je me heurte actuellement à deux problèmes :
1- par moment l'userform "bloque". Il reste figé comme lors d'un plantage Excel avec un message d'erreur dans son Caption (Ne répond pas...), puis m'affiche "l'image finale".
Je pense que cela est du aux .Repaint en boucles... A voir.

2- Le dé ne respecte pas l'obstacle que représente le bord bas de l'UserForm. Il "déborde" vers le bas. Je n'ai pas ce souci avec les 3 autres bords (quoiqu'un léger souci avec le bord droit...).
Ce problème est matérialisé, dans le code, par des commentaires :
'///////////////////////SOUCI


Pour vous rendre compte, par vous mêmes, vous pouvez, au choix, télécharger mon fichier exemple : sur cjoint.com, ou faire votre propre fichier.
Dans un cas, comme dans l'autre, vous aurez besoin des images des dés (à renommer : 1.jpg, 2.jpg etc... 6.jpg)


Pour faire votre propre fichier, dans un classeur vierge :
- insérez un UserForm (propriété Name : "Piste")
- dessinez y un contrôle Image (propriété Name : "ImageDe")

Les codes :
Module de l'UserForm :
Option Explicit

Dim StopIt As Boolean

Private Sub UserForm_Initialize()
With Me
    .Height = 700
    .Width = 700
    .BackColor = 32768
    .Caption = "Piste de dés"
    With .ImageDe
        .Height = 24
        .Width = 24
        .Visible = False
    End With
End With
End Sub

'Pour calculer la force de lancer du dé (entre 1 et 100), le joueur doit maintenir le bouton gauche de la souris appuyé
'durant tout le temps ou ce bouton est maintenu (UserForm_MouseDown), la variable Force varie de 1 à 100 et de 100 à 1
'l'arrêt de cette procédure se fait en relachant le bouton (UserForm_MouseUp)
'la variable Boolean StopIt, déclarée en entête de ce module, combinée au DoEvents permet cet arrêt
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim i As Integer
'initialisation de la variable Force (à chaque clic dans l'UserForm)
Force = 1
StopIt = False
'la variable i prends les valeurs uniques 1 &  -1
'Elle sert donc à faire varier le "sens" d'incrémentation de la variable Force :
'quand i = 1, Force varie de 1 vers 100
'quand i = -1, Force varie de 100 vers 1
Do While StopIt = False
    Force = Force + (1 * i)
    If Force = 1 Then i = 1
    If Force = 100 Then i = -1
    DoEvents 'permet de déclencher l'événement Mouse_Up et donc de Stopper cette boucle
Loop
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
StopIt = True
Jeter_Les_Des
End Sub


Dans un module standard :
Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Force As Integer

Dim De_Left As Integer, De_Top As Integer
Dim Coeff_Sens_Left As Double, Coeff_Sens_Top As Double

Sub Jeter_Les_Des()
Dim Tb(), i As Integer, Chemin As String, Cpt As Integer, Attente As Long

'Initialisation des variables
Chemin = ThisWorkbook.Path & "" '=> Pour les images à afficher dans le contrôle ImageDe
Randomize Timer ' => Tirages aléatoires
Attente = 80 + (100 - Force) ' => Représente la vitesse initiale du dé

Call Mouvements_Du_De(Tb())  ' Calcule et stocke toutes les positions du dés + ses valeurs

For i = LBound(Tb, 2) To UBound(Tb, 2) ' Boucle sur toutes les positions prévues du dé
    'ralenti le dé
    Cpt = Cpt + 1
    If Cpt >= UBound(Tb, 2) / 10 Then
        Cpt = 0
        Attente = Attente + 20
    End If
    'affiche l'image du dé
    With Piste
        With .ImageDe
            .Move Tb(1, i), Tb(2, i), 24, 24
            .Visible = True
            .Picture = LoadPicture(Chemin & Tb(3, i) & ".jpg")
            .PictureSizeMode = fmPictureSizeModeStretch
        End With
        .Repaint
    End With
    Sleep Attente
Next i
End Sub

'Calcule et stocke toutes les positions du dés + ses valeurs
'Les données, stockées dans une variable tableau, sont : Left + Top + Valeur du dé
Sub Mouvements_Du_De(ByRef Tbl())
Dim i As Integer, Valeur_Du_De As Byte, FinBoucle As Integer

'Si la force =  1, il n'y aura pas de mouvement. Le dé tombe sur la piste.
'Dans ce cas, on ne lance que la procédure Point_De_Chute_Du_De.
If Force = 1 Then
    Call Point_De_Chute_Du_De(Tbl())
    Exit Sub
End If

'Point_De_Chute_Du_De => calcule aléatoirement ou va tomber le dé.
Call Point_De_Chute_Du_De(Tbl())
'Sens_Aleatoire => Calcule aléatoirement un coefficient Left et un coefficient Top
'Ces deux coefficients, multipliés à des constantes (en fonction de la force),
'nous donnent les coordonnées des emplacements du dé.
Call Sens_Aleatoire

'Initialisation variable
'La force va diminuer au fur et à mesure de la boucle, on stocke donc sa valeur initiale.
FinBoucle = Force

For i = 2 To FinBoucle
    'calcul des coordonnées de l'emplacement suivant, en fonction de l'emplacement actuel.
    De_Left = Tbl(1, i - 1) + (Force * 1.5) * Coeff_Sens_Left
    De_Top = Tbl(2, i - 1) + (Force * 1.5) * Coeff_Sens_Top
    
    '******************************************************************************************* A Faire.
    
    'Apporter un coeff supplémentaire à une des deux "directions" pour donner un effet moins linéaire aux déplacements
    
    '*******************************************************************************************
    
    'Permet de changer de sens lorsque le dé touche un des bords de la piste
    If De_Left < 0 Then
        Coeff_Sens_Left = Coeff_Sens_Left * -1
        De_Left = 0
    End If
    'Pas de valeur numérique => permet de changer la taille de l'UserForm
    If De_Left >= Piste.Width - Piste.ImageDe.Width Then
        Coeff_Sens_Left = Coeff_Sens_Left * -1
        De_Left = Piste.Width - Piste.ImageDe.Width '///////////////////////SOUCI "Léger"
    End If
    If De_Top < 0 Then
        Coeff_Sens_Top = Coeff_Sens_Top * -1
        De_Top = 0
    End If
    If De_Top >= Piste.Height - Piste.ImageDe.Height Then
        Coeff_Sens_Top = Coeff_Sens_Top * -1
        De_Top = Piste.Height - Piste.ImageDe.Height '///////////////////////SOUCI "Important"
    End If
    
    '*******************************************************************************************A modifier.
    'En fin de mouvement du dé, le dé roule et donc un 4 (par ex) ne peut pas être suivi :
        '- ni pas un 4 (dé glissé),
        '- ni par un 3 (situé sur l'autre face)
    Valeur_Du_De = CInt((5 * Rnd()) + 1)
    '*******************************************************************************************
    
    'stockage des valeurs
    ReDim Preserve Tbl(1 To 3, 1 To i)
    Tbl(1, i) = De_Left
    Tbl(2, i) = De_Top
    Tbl(3, i) = Valeur_Du_De
    'Baisse de la force => le dé va de moins en moins loin par rapport à sa position actuelle
    Force = CInt(Force - (Force / 20))
Next i
End Sub

Sub Point_De_Chute_Du_De(ByRef Tabl())
'calcul aléatoire des 3 valeurs initiales du dé
Erase Tabl
ReDim Preserve Tabl(1 To 3, 1 To 1)
Tabl(1, 1) = CInt((675 * Rnd()) + 1) ' => Propriété Left
Tabl(2, 1) = CInt((675 * Rnd()) + 1) ' => Propriété Top
Tabl(3, 1) = CInt((5 * Rnd()) + 1) ' => Valeur
End Sub

Sub Sens_Aleatoire()
'calcul aléatoire de Coeff_Sens_Left et Coeff_Sens_Top pour la première direction
Dim Valeurs(200), i As Long

'Les 2 coeffs sont des valeurs comprises entre -1 et +1 Step 0.01 : -1, -0.99, -0.98, ...
For i = -100 To 100
    Valeurs(i + 100) = i / 100
Next i
'calcul aléatoire de Coeff_Sens_Left et Coeff_Sens_Top
Coeff_Sens_Left = Valeurs(CInt((199 * Rnd()) + 1))
Coeff_Sens_Top = Valeurs(CInt((199 * Rnd()) + 1))
End Sub


Merci de m'avoir lu jusqu'ici et pour vos éventuels éclaircissements.

Cordialement,
Franck
A voir également:

23 réponses

Messages postés
28912
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
7 juillet 2020
332
Bonjour,
Essaye ça :
 'Permet de changer de sens lorsque le dé touche un des bords de la piste
    If De_Left < 0 Then
        Coeff_Sens_Left = Coeff_Sens_Left * -1
        De_Left = 0
    End If
    'Pas de valeur numérique => permet de changer la taille de l'UserForm
    If De_Left >= Piste.Width - (Piste.ImageDe.Width + 2) Then
        Coeff_Sens_Left = Coeff_Sens_Left * -1
        De_Left = Piste.Width - (Piste.ImageDe.Width + 2) '///////////////////////SOUCI "Léger"
        Debug.Print ("Piste.Width" & Piste.Width & "  Piste.ImageDe.Width:" & Piste.ImageDe.Width)
        Debug.Print ("De_Left : " & De_Left)
    End If
    If De_Top < 0 Then
        Coeff_Sens_Top = Coeff_Sens_Top * -1
        De_Top = 0
    End If
    If De_Top >= Piste.Height - 2 * Piste.ImageDe.Height + 2 Then
        Coeff_Sens_Top = Coeff_Sens_Top * -1
        De_Top = Piste.Height - 2 * Piste.ImageDe.Height + 2 '///////////////////////SOUCI "Important"
    End If

Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Salut Jordane45,

Merci de ta réponse, effectivement je n'avais pas vérifié ces valeurs.
Mais bon...
J'ai testé sur les valeurs Top car c'est plus flagrant.
En "Debug" comme ceci :
De_Top = Piste.Height - Piste.ImageDe.Height 
Debug.Print ("Piste.Height : " & Piste.Height & " - Piste.ImageDe.Height : " & Piste.ImageDe.Height)
Debug.Print ("De_Top : " & De_Top)

J'obtiens :
Piste.Height : 700 - Piste.ImageDe.Height : 24
De_Top : 676
Ce qui, logiquement est correct. Mon dé ne devrait passer dépasser le cadre de l'UserForm.
Or, visuellement, il y va carrément.
D'où mon interrogation.
Ne serait ce pas du à la hauteur de la barre de fenêtre de l'UserForm qui devrait être prise en compte?
Autre piste : une quelconque "marge" due à un "je ne sais quoi" dans ma configuration?
Messages postés
28912
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
7 juillet 2020
332
Il me semble que c'est la barre du USF qui rentre en compte....
En gros ton USF fait 700.... mais la ZONE à l'intérieur est plus petite...

Tu peux t'en rendre compte en déplaçant manuellement ton DE dans l' USF en mode création ...
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Bien vu le coup du Mode création...

On se rends compte que pour un UserForm de propriété Height = 700, avec un contrôle image de propriété Height = 24, la valeur de la propriété Top du contrôle Image, lorsqu'il est situé sur le "Bottom" de l'UserForm est égale à 654 au lieu de 676...

Idem pour la propriété Left qui est de 672 au lieu de 676

Merci. Ce souci est donc résolu.

Ne me reste plus que le problème 1- de message d'erreur dans son Caption (Ne répond pas...)
Messages postés
28912
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
7 juillet 2020
332
Au passage... vu la taille de ton dé.... et vu que tout le monde n'a pas la change d'avoir de grands écrans... je pense que tu devrais réduire ta zone de lancé....

Perso quand j'ai fait les tests.. j'ai réduis à 400*400
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Oui, bien entendu.
Au passage, il convient, pour pouvoir modifier la taille de l'UserForm, de changer la Sub Point_De_Chute_Du_De comme ceci :
Sub Point_De_Chute_Du_De(ByRef Tabl())
'calcul aléatoire des 3 valeurs initiales du dé
Dim intLeft As Integer, intTop As Integer
intLeft = Piste.Left - 5
intTop = Piste.Top - 22
Erase Tabl
ReDim Preserve Tabl(1 To 3, 1 To 1)
Tabl(1, 1) = CInt((intLeft * Rnd()) + 1) ' => Propriété Left
Tabl(2, 1) = CInt((intTop * Rnd()) + 1) ' => Propriété Top
Tabl(3, 1) = CInt((5 * Rnd()) + 1) ' => Valeur
End Sub


Et ce afin d'éviter que le dé ne commence en dehors du plateau...
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Bonjour, Pijaku,
ton "doevents" est ici maladroit :
Do While StopIt = False
Force = Force + (1 * i)
If Force = 1 Then i = 1
If Force = 100 Then i = -1
DoEvents 'permet de déclencher l'événement Mouse_Up et donc de Stopper cette boucle
Loop
car il est de nature à torturer indûment ton processeur.
Préfère-lui la mise en place d'un timer
Au minimum : laisse un peu respirer (une attente de 0,05 secondes, par exemple) entre l'affichage de deux images successives.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
J'ai retrouvé cet ancien code qui me faisait la même chose alors que là nous n'avons pas d'UserForm, une fois sur deux il s'arrête en cours d'exécution, le caption de la fenêtre indique (Ne répond pas...) et pourtant, si on ne touche à rien, il termine la procédure et affiche l'image "finale" :

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Colorie_En_Diagonale()
Dim Wsh As Worksheet

Set Wsh = Worksheets("Feuil1")
MetEnForme Wsh
Colore Wsh, 15, 6, 6, 15, 6, False, False
'Colore Feuil récursivité, Ligne 15, Col F, 6 = Coloriee représente la col ou la lig en cours de coloriage,
'dernière (lig ou col), premiere (ligne ou colonne), False = variable fin de "chemin" en colonnes
'False dernier paramètre = Fin de l'exécution du code
End Sub
Sub MetEnForme(Sh As Worksheet)
Application.ScreenUpdating = False
With Sh.Range("A1:AA30")
    .ColumnWidth = 3
    .RowHeight = 19.5
End With
Application.ScreenUpdating = True
End Sub
Sub Colore(Wsh As Worksheet, Lig As Integer, Col As Integer, Coloriee As Integer, Dern As Integer, prem As Integer, Fin As Boolean, termine As Boolean)
If Wsh.Cells(Lig, Col).Interior.ColorIndex = -4142 Then Wsh.Cells(Lig, Col).Interior.ColorIndex = 3 Else Wsh.Cells(Lig, Col).Interior.ColorIndex = -4142
If termine = True Then MsgBox "Fini": Exit Sub
Sleep 100
If Lig <= Dern And Lig >= prem And Col >= prem And Col <= Dern And Fin = False Then
    If Col = prem Then
        Coloriee = Coloriee + 1
        If Coloriee = Dern Then Fin = True
        Colore Wsh, Dern, Coloriee, Coloriee, Dern, prem, Fin, termine
    Else
        Colore Wsh, Lig - 1, Col - 1, Coloriee, Dern, prem, Fin, termine
    End If
Else
    If Lig = prem Then
        Coloriee = Coloriee - 1
        If Coloriee = prem Then termine = True
        Colore Wsh, Coloriee, Dern, Coloriee, Dern, prem, Fin, termine
    Else
        Colore Wsh, Lig - 1, Col - 1, Coloriee, Dern, prem, Fin, termine
    End If
End If
End Sub


Ne serait-ce pas plutôt la fonction Sleep qui planterait le truc?
C'est le seul point commun entre ces deux codes...
Messages postés
28912
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
7 juillet 2020
332
Pour ma part... les seules fois où j'ai constaté le plantage (sur le lancé de dés) c'est lorsque je recliquais dans Excel ou que j'essayais de déplacer la userform....
Le SLEEP.. j'y avais pensé aussi.... peut être vaudrait il mieux utiliser les fonctions "internes" d'excel : Application.wait ...
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
j'y ai songé. Mais... (oui je sais, je suis pénible avec mes mais...)
Application.Wait, tout comme Application.OnTime ont une précision d'une seconde. Ici, la précision souhaitée pour avoir un (tout relatif) mouvement "fluide" est de l'ordre de 100 milli-secondes, voire moins si possible.

Entre autre, j'ai vu des fonctions bricolées à la mano, mais elles utilisent toutes des DoEvents en boucle, ce que je veux éviter pour les raisons données ci-dessus par ucfoutu.
Il en va de même pour l'utilisation de GetTickCount()...

Je vais donc continuer de chercher.
Messages postés
28912
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
7 juillet 2020
332
En même temps.... essayer de faire avec EXCEL une "animation" de ce type .... c'est un peu comme dire que tu vas réparer une montre suisse avec la caisse à outils d'un plombier... il ne faut pas s'attendre à des miracles...
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Tout à fait. J'en suis bien conscient.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Bon et bien après quelques tests (je ne cries pas victoire trop vite), que je vais continuer à pousser, il s'avère qu'il existe une alternative à Sleep.
C'est bien cette fonction qui faisait planter le bouzin...
Par conséquent, il suffit de la remplacer par une fonction "maison" qui utilise le Timer, en lui faisant réaliser une action inutile.
Du genre :

Sub Attendre(Duree As Single)
Dim t As Single, i As Byte, k As Byte, Tb(1)
t = Timer
k = 1
Do
'je l'ai bien dit que c'est n'importe quoi...
If i Mod 2 = 0 Then Tb(k) = i
Loop While CDbl(Format(Timer - t, "#0.00000")) < Duree
Debug.Print Format(Timer - t, "#0.00000")
End Sub


Le code d'appel est, tout simplement :
Attendre 0.05 'attente de 5 centièmes de secondes


C'est précis à un centième de seconde et demi (0.015 seconde) près... Ce qui est déjà très bien pour Excel et VBA.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Qu'en pensez-vous?
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
J'éviterais personnellement les doevents inutiles (n'appelant le doevents que lorsque nécessaire).
L'installation d'un timer (avec addressof) aurait ma préférence.
Mais tu peux éviter l'utilisation de l'API de Windows et te contenter de Application.Ontime, tout en ayant une fréquence meilleure que de 1 seconde, en t' amusant. Ainsi, par exemple :
sur un userform : un bouton de commande CommandButton1 et un Label Label1 et ce code :
Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
actif = True
Application.OnTime Now, "titi" ' on "lance" sans attendre
End Sub

Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
actif = False
End Sub


et dans un Module :
Private der As Double, cpt As Long
Public actif As Boolean
Public Sub titi()
If Timer > der + 0.05 Or der = 0 Then
cpt = cpt + 1 ' | ou toutes autres
UserForm1.Label1.Caption = cpt ' | actions de ton choix
DoEvents ' un doevents qui n'interviendra que si condition remplie
' (si + de 0,05 sec écoulées
der = Timer
End If
If actif Then
Application.OnTime Now, "titi" ' on "relance" aussitôt"
Else
cpt = 0
der = 0
End If
End Sub
La variable cpt n'est là que pour simuler et visualiser une "action"
La variable der n'est là que pour pallier l'inconvénient qui pourrait résulter d'un passage à Minuit.

J'ai allégé ce matin (fatigué et bâclé hier)

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" facilitera les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement répéter son contenu. Je n'interviend
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Salut,

J'ai allégé ce matin (fatigué et bâclé hier)
En fait, à la lecture de ta réponse hier soir, j'ai cru que tu avais laissé les TimeValue(00:00:00) pour les éventuels néophytes qui tomberaient sur ta réponse après une recherche Google sur le mot OnTime. Je trouvais ça judicieux, pour eux...
Mais il est vrai que je n'en aurais pas tenu compte.

Je vais me hâter d'aller tester cela.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Re-

Le retour après test est plus que très satisfaisant.
Non seulement ton code réalise ce que je souhaitais à la base, mais, de plus, il est évolutif et économe en ressources.

En le regardant de plus près, j'ai souhaité connaitre, pour les deux méthodes, le nombre de DoEvents pour une seconde. J'ai donc intégré, à mon code, un compteur, et au tien un arrêt au bout d'une seconde.
Le résultat est éloquent.
Même en baissant l'intervalle de "relance" de ta procédure "titi" à 0.005 seconde, le nombre maximal de DoEvents est de 66. Ceci, grâce à la non relance systématique ET aux petites actions réalisées par ta procédure.
Une boucle d'une seconde, sans action, ni pause, comptabilise elle entre 47000 et 48000 DoEvents.

Voici les deux procédures de test que j'ai utilisé (sans UserForm, dans un module standard) :
Private der As Double, cpt As Long
Public actif As Boolean
Dim t As Single

Sub Compte_DoEvents_Pijaku()
Dim L As Long
Dim i As Integer

Force = 1
t = Timer
Do While Timer < t + 1
    Force = Force + (1 * i)
    If Force = 1 Then i = 1
    If Force = 100 Then i = -1
    L = L + 1
    DoEvents
Loop
MsgBox L
End Sub


Sub Compte_DoEvents_Ucfoutu()
t = Timer
Application.OnTime Now, "titi"
End Sub
Sub titi()
  If Timer > der + 0.009 Or der = 0 Then
    cpt = cpt + 1
    DoEvents
    der = Timer
  End If
  'termine au bout d'une seconde après lancement
  If Timer < t + 1 Then actif = True Else actif = False
  If actif Then
    Application.OnTime Now, "titi"
  Else
    MsgBox cpt
    cpt = 0
  End If
End Sub
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Bon ...
je vais maintenant aborder un autre aspect important :
celui d'un Doevents qui ne concernerait pas la totalité des messages du système, mais uniquement ceux destinés à l'application.
Le distinguo est très important : en "contrôlant", on ne "rend la main" au système que lorsque l'appli en cours est elle-même concernée par un message (quel qu'il puisse être). Ce sera bien évidemment le cas du MouseUp de ton bouton ...
De cette manière : aucune "dépense" due au Doevents si l'appli n'est pas concernée elle-même. Lde gain de temps est considérable.
Je vais (cet aprem) te concocter une petite démo et te la faire parvenir par MP.
Elle risquera (suis encore fatigué) d'être assez "bâclée", mais elle sera sans aucun doute très "parlante".
Je compterai sur toi pour en faire (et le déposer) un source commenté (agrémenté à ta sauce) car je ne me sens pas encore en parfait état pour faire ce dépôt.
A cet aprem
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Pas de souci.
Pense également à te reposer, je serais encore là et disponible la semaine prochaine... Il n'y a pas d'urgence.

En attendant, je vais lire ce qui existe par rapport à DoEvents.
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Bon....
Nous allons maintenant considérer deux choses distinctes, Pijaku :
1) l'utilité de faire un petit tuto/démo sur la base de ce que tu sais maintenant (mes MP)... et je te laisserai faire (tu l'as promis).
2) une approche de ton problème de dés.
Je te laisse, pour ce second point UNIQUEMENT regarder ce que ferait ceci, qui s'appuie sur différents aspects, dont celui que je t'ai exposé par MP. Il devrait t' "inspirer" assez, ... je pense ...
Sur nun userform :
- 1 bouton de commande Commandbutton1
- 1 textbox textbox1 placée en dessous
et ce code :
Private Declare Function GetInputState Lib "user32" () As Long
Private toto As Boolean


Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim sens As Integer, pas As Double, cpt As Integer
toto = False
Me.Caption = "pression en cours"
sens = -1
pas = 15
Do
deb = Timer
Do While Timer - deb < 0.02
Loop
If TextBox1.Left <= pas Or TextBox1.Left + TextBox1.Width + pas >= Me.Width Then
sens = -sens
End If
pas = pas * 0.992 ' on ralentit peu à peu le déplacement
TextBox1.Move TextBox1.Left + (sens * pas)
If pas < 0.2 Then toto = False: Exit Do ' si presque immobile, on l'arrête

If GetInputState And Not toto Then
DoEvents
cpt = cpt + 1
End If
Me.Repaint
Loop Until toto = True
Me.Caption = "le doevents n'a été utilise que " & cpt & " fois"
toto = False
End Sub
Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
toto = True ' pour interrompre la boucle
End Sub
Que fait-il ?
1) Il lance en boucle le déplacement de la textbox au keydown
2) le déplacement de la textbox est ralenti au fur et à mesure du déplacement
3) la boucle est interrompue au MouseUp, à tout instant
4) si l'on ne fait pas de MouseUp, la boucle est également interrompue au bout d'un certain temps (et ralentissement)

Observe le caption du UserForm : si interruption volontaire : un seul Doevents. Si interruption au bout d'un certain temps : même pas besoin d'un Doevents.
Ce code est tout simplement une "conjugaison" de tout ce que tu sais maintenant.
Amitiés
EDIT : amuse-toi ensuite à faire varier le pas et le coef de ralentissement
par ex : pas = 50 et coef = 0.94 au lieu de 0.992
"joue" également avec la limite d'arrêt (If pas < 1 Then toto = False: Exit Do)
(arrange à ton goût ...très flexible).



________________________
Réponse exacte ? => "REPONSE ACCEPTEE" facilitera les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement répéter son contenu. Je n'interviend
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Après réflexion et essais, il est plus réaliste et plus exact d'écrire ainsi le MouseDown :
Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim sens As Integer, pas As Double, cpt As Integer, cogne As Boolean
toto = False
Me.Caption = "pression en cours"
sens = -1
pas = 60
Do
deb = Timer
Do While Timer - deb < 0.04
Loop
pos = TextBox1.Left + (sens * pas)

Select Case pos
Case Is <= 0: pos = 0: cogne = True
Case Is >= Me.Width - TextBox1.Width: pos = Me.Width - TextBox1.Width: cogne = True

End Select
If cogne Then ' si l'on a cogné un bord
sens = -sens ' on inverse alors le sens
pas = pas * 0.6 ' ralentissement additionnel du fait du choc
cogne = False
End If
TextBox1.Left = pos
pas = pas * 0.98 ' on ralentit peu à peu le déplacement, de manière générale
If pas < 2 Then toto = False: Exit Do ' si presque immobile, on l'arrête
If GetInputState And Not toto Then
DoEvents
cpt = cpt + 1
End If
Me.Repaint
Loop Until toto = True
Me.Caption = "le doevents n'a été utilise que " & cpt & " fois"
toto = False
toto = False
End Sub
Laz textbox atteint ainsi parfaitement les deux côtés, d'une part.
Et, d'autre part, chaque choc sur un côté provoque (logique) un ralentissement complémentaire.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Bonjour,

Ne connaissant pas, avant ce week end, la fonction GetInputState, il faut que j'étudie cela au calme.
J'ai déjà saisi son utilité, il ne reste qu'à adapter ton code (ce n'est pas compliqué, mais je préfères poser cela tranquillement).
Quand au "format" de ce que l'on peut en tirer, ce sera, très certainement un tuto accompagné d'une source, pourquoi pas.

Je me penche dessus... juste après mon café!
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
C'est parfait!

La démarche que je suis pour lancer un dé :
Dans la "vie réelle", lorsqu'on lance un dé, on gère la force et la direction, et après, le dé se "débrouille" seul.
Dans mon UserForm, la force est déterminée par l'appui (+ ou - long) sur un bouton de commande (Mouse_Down), la direction est déterminée lors de l'événement Mouse_Up, le déplacement du dé par une procédure simple.
En voici l'exemple ou n'est pas encore traité le déplacement vertical, exemple basé sur ton code ucfoutu, scindé en deux parties : calcul de la force et déplacement du dé.
Toujours un UserForm avec un CommandButton et un TextBox (qui, à terme, sera remplacé par une contrôle Image) :

Option Explicit

Private Declare Function GetInputState Lib "user32" () As Long

Private toto As Boolean, pas As Double

Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim sens As Integer, cpt As Integer
  
  toto = False
  sens = 1
  TextBox1.Visible = False
  CommandButton1.Caption = "Relachez pour lancer le dé"
  Me.Repaint
  pas = 1
  
  Do
    If pas = 70 Or pas = 0 Then sens = sens * -1
    pas = pas + (1 * sens)
    
    If GetInputState And Not toto Then
      DoEvents
      cpt = cpt + 1
    End If
  Loop Until toto = True
End Sub
Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  toto = True ' pour interrompre la boucle
  'Direction
  TextBox1.Visible = True
  Lancer
End Sub

Private Sub UserForm_Initialize()
  TextBox1.Visible = False
  CommandButton1.Caption = "Maintenez pour calculer la force du lancer"
  Me.Caption = ""
End Sub

Sub Direction()
End Sub

Sub Lancer()
 Dim sens As Integer, cogne As Boolean, deb As Double, pos As Double

  sens = -1
  Me.Caption = "Dé lancé"
  Do
    deb = Timer
    Do While Timer - deb < 0.04
    Loop
    pos = TextBox1.Left + (sens * pas)
    
    Select Case pos
       Case Is <= 0: pos = 0: cogne = True
       Case Is >= Me.Width - TextBox1.Width: pos = Me.Width - TextBox1.Width: cogne = True
    End Select
    
    If cogne Then ' si l'on a cogné un bord
      sens = -sens ' on inverse alors le sens
      pas = pas * 0.6 ' ralentissement additionnel du fait du choc
      cogne = False
    End If
    
    TextBox1.Left = pos
    pas = pas * 0.98  ' on ralentit peu à peu le déplacement, de manière générale
    If pas < 2 Then Exit Do   ' si presque immobile, on l'arrête
    Me.Repaint
  Loop
  With Me
    .CommandButton1.Visible = True
    .CommandButton1.Caption = "Maintenez pour calculer la force du lancer"
    .Caption = "Relancez le dé..."
  End With
End Sub


Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Bon,
Je vais alors faire un petit exemple avec déplacements dans tous les sens ... (un exemple de base, qu
A très bientôt (il ne devrait pas me falloir plus de six minutes).
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Voici comment j'ai "géré" le déplacement dans tous les sens :
coef_X et coef_Y sont déclarées As Double en tête de module

Sub Direction()
Dim Valeurs(200), i As Long

Randomize Timer
'Les 2 coeffs sont des valeurs comprises entre -1 et +1 Step 0.01 : -1, -0.99, -0.98, ...
For i = -100 To 100
    Valeurs(i + 100) = i / 100
Next i
'calcul aléatoire de Coeff_X et Coeff_Y
coef_X = Valeurs(CInt((199 * Rnd()) + 1))
coef_Y = Valeurs(CInt((199 * Rnd()) + 1))
End Sub

Sub Lancer()
 Dim sens As Integer, cogneH As Boolean, cogneV As Boolean, deb As Double, posH As Double, posV As Double

  With Me
    .CommandButton1.Visible = False
    .Caption = "Dé lancé..."
    Do
      'temps de pause
      deb = Timer
      Do While Timer - deb < 0.04
      Loop
      
      'calcul de la position du dé posH = Left, posV = Top
      posH = .TextBox1.Left + (pas * coef_X)
      posV = .TextBox1.Top + (pas * coef_Y)
    
      'En fonction de la position, regarde si le dé touche les bords
      'bords verticaux
      Select Case posH
       Case Is <= 0: posH = 0: cogneH = True
       Case Is >= .Width - .TextBox1.Width - 4: posH = .Width - .TextBox1.Width - 4: cogneH = True
      End Select
      'bords horizontaux
      Select Case posV
       Case Is <= 0: posV = 0: cogneV = True
       Case Is >= .Height - .TextBox1.Height - 21: posV = .Height - .TextBox1.Height - 21: cogneV = True
      End Select
      ' si l'on a cogné un bord vertical
      If cogneH Then
        coef_X = -coef_X ' on inverse alors le sens
        pas = pas * 0.6 ' ralentissement additionnel du fait du choc
        cogneH = False
      End If
      ' si l'on a cogné un bord horizontal
      If cogneV Then
        coef_Y = -coef_Y ' on inverse alors le sens
        pas = pas * 0.6 ' ralentissement additionnel du fait du choc
        cogneV = False
      End If
    
      .TextBox1.Move posH, posV
      pas = pas * 0.98  ' on ralentit peu à peu le déplacement, de manière générale
      If pas < 2 Then Exit Do   ' si presque immobile, on l'arrête
      .Repaint
    Loop
    
    .CommandButton1.Visible = True
    .CommandButton1.Caption = "Maintenez pour calculer la force du lancer"
    .Caption = "Relancez le dé..."
  End With
End Sub


EDIT :
Mais j'attends impatiemment ta vision des choses. En fait, je n'aime pas trop ce "dédoublement" d'actions... Mais n'ayant trouvé que cela.
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Bon,
1) pour éviter des calculs additionnels dus à la barre de titre de l'userform, nous allons utiliser un Frame (rien ne t'empêche, si tu le veux, de lui donner carrément les dimensions de ton userform.
Et nous allons déplacer la textbox dans les deux sens à l'intérieur de ce Frame (Frame1)
2) sur un userform :
- 1 Frame Frame1 rectangulaire de 150 x 186, sans caption et avec une bordure (option 1). Rectangulaire et non carré si l'on veut n'avoir qu'un pas. Si carré, va falloir deux pas différents (un vertical et l'autre horizontal, sinon on ne parcourra bien évidement qu'une diagonale )
- dans ce frame (en mode création) : une textbox de 25 x 25
- un bouton de commande commandbutton1 (en dehors du Frame) avec ce code modifié (tout le reste restant identique) :

 Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim sensh As Integer, pas As Double, cpt As Integer, cogneh As Boolean, cognev As Boolean
toto = False
Me.Caption = "pression en cours"
sensh = -1
sensv = -1
pas = 200
Do
deb = Timer
Do While Timer - deb < 0.02
Loop
posh = TextBox1.Left + (sensh * pas)
posv = TextBox1.Top + (sensv * pas)
Select Case posh
Case Is <= 0: posh = 0: cogneh = True
Case Is >= Frame1.Width - TextBox1.Width: posh = Frame1.Width - TextBox1.Width: cogneh = True
End Select
Select Case posv
Case Is <= 0: posv = 0: cognev = True
Case Is >= Frame1.Height - TextBox1.Height: posv = Frame1.Height - TextBox1.Height: cognev = True
End Select
If cogneh Then ' si l'on a cogné un bord
sensh = -sensh ' on inverse alors le sens
pas = pas * 0.8 ' ralentissement additionnel du fait du choc
cogneh = False
End If
If cognev Then ' si l'on a cogné un bord
sensv = -sensv ' on inverse alors le sens
pas = pas * 0.8 ' ralentissement additionnel du fait du choc
cognev = False
End If
TextBox1.Move posh, posv
pas = pas * 0.98 ' on ralentit peu à peu le déplacement, de manière générale
If pas < 2 Then toto = False: Exit Do ' si presque immobile, on l'arrête
If GetInputState And Not toto Then
DoEvents
cpt = cpt + 1
End If
Me.Repaint
Loop Until toto = True
Me.Caption = "le doevents n'a été utilise que " & cpt & " fois"
toto = False
End Sub
Les reactions sont les mêmes que précédemment en ce qui concerne une pression continue ou une pression interrompue. Seule différence : parcours dans les deux sens
Tu peux t'amuser à décider aléatoirement, à chaque lancer :
- de la position de départ,
- du sens
- de la valeur du pas,
etc ...

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" facilitera les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement répéter son contenu. Je n'interviend
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Bon ... je viens de voir ton code. On se rejoint.
Y compris dans le nommage des variables ... (h et v)
Edit : si tu ne veux pas "doubler" le code, rien ne t'empêche de créer deux petites procédures paramétrées (l'une pour l'étape select case et l'autre pour ce qui est des sens et ralentissements)
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Oui en effet, on se rejoint.
Mais...
N'y a t'il pas (je ne me rappelle plus mes leçons de mathématiques du lycée...) une méthode plus directe?
Du style un seul coefficient à appliquer qui passerait d'un point A à un point B en modifiant ses coordonnées X et Y en une seule opération...
Je crois vaguement me souvenir d'une règle concernant les vecteurs et ... peut être ... un coefficient directeur.
Je vais voir de ce côté si l'on ne pourrait pas alléger le code.

Ensuite, j'essaie de faire les choses dans l'ordre, mais pour l'instant j'ai tout en tête et ne vous les livre que progressivement... Désolé si j'ai omis un "détail" qui s'avèrerait indispensable.
Pour l'instant, il n'est question du déplacement d'un seul dé. Si je décide de lancer plusieurs dés, le souci que je vais rencontrer est celui du "choc" entre les dés. Je ne me suis pas encore posé cette question, mais cela te semble t'il réalisable avec la piste que nous exploitons en ce moment?
Je précise que je ne souhaites pas le code tout fait, du moins pas tant que je n'ai pas essayé par moi-même...

Je vais également ajouter un "effet" au mouvement du (des) dé(s) afin d'obtenir un mouvement moins linéaire. Cela ne constitue pas une grosse difficulté.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Rectangulaire et non carré si l'on veut n'avoir qu'un pas
J'ai résolu ce problème en ajoutant deux coefficients. Un vertical et un horizontal. Cela permet également de se passer du sens...
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Tu peux toujours te déplacer sur des vecteurs (d'équation y = ax + b), mais cela va te compliquer les choses et non les faciliter.
Si tu y tiens toutefois, tu trouveras comment procéder en examinant l'un des sources que j'ai déposé il n'y a que quelques mois à ce sujet.
A tout hasard (si tu ne l'a pas trouvé) ===>>

http://codes-sources.commentcamarche.net/source/53889-vb6-deplacement-d-un-controle-sur-un-segment-de-droite-delimite-par-deux-points-de-coordonnees-connues
________________________
Réponse exacte ? => "REPONSE ACCEPTEE" facilitera les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement répéter son contenu. Je n'interviend
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
cela va te compliquer les choses et non les faciliter
Après lecture de ta source, ... je confirme.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Bonjour,

J'ai évoqué, ci-dessus, la possibilité de lancer plusieurs dés.
J'ai réussi à faire quelque chose, mais cela ne me convient pas entièrement.

Pour associer l'utile à l'agréable, j'ai réalisé cela avec un module de classe, étant novice en cette matière cela me semblait judicieux.
Tout fonctionne bien mais, comme dit plus haut, je ne suis pas satisfait.
Ma question est la suivante : comment ajouter une propriété à un objet de manière permanente, sans qu'il retourne systématiquement dans le module de classe pour recalculer...

Exemple de ce que j'ai fait :
Dans un module standard :
Public mesImages() As New Classe1


Dans le module de l'UserForm, à l'initialize :
  For Each Ctrl In Me.Controls
    If Ctrl.Name Like "Image*" Then
        Nb_Des = Nb_Des + 1
        ReDim Preserve mesImages(1 To Nb_Des)
        Ctrl.Visible = False
        Set mesImages(Nb_Des).Imgs = Ctrl
    End If
  Next Ctrl


Dans le module de classe :
Public WithEvents Imgs As MSForms.Image

Property Get coef_X() As Double
Dim Valeurs(), i As Long
  ReDim Preserve Valeurs(200)
  For i = -100 To 100
    Valeurs(i + 100) = i / 100
  Next i
  'calcul aléatoire de Coeff_X
  coef_X = Valeurs(CInt((199 * Rnd()) + 1))
End Property

Property Get coef_Y() As Double
Dim Valeurs(), i As Long
  ReDim Preserve Valeurs(200)
  For i = -100 To 100
    Valeurs(i + 100) = i / 100
  Next i
  'calcul aléatoire de Coeff_X
  coef_Y = Valeurs(CInt((199 * Rnd()) + 1))
End Property


Je pensais, naïvement, que, à l'initialisation de mon UserForm, il allait me calculer, pour chaque image, ses propres propriétés Coef_X et coef_Y et qu'après, dans le code, je pourrais les retrouver en faisant : mesImages(indice).coef_X.
Malheureusement, cette façon de faire recalcule systématiquement mes coef_X et coef_Y. Or, comme vous l'avez constaté, ceux-ci sont aléatoires, mais ne doivent l'être qu'une fois, à l'initialisation...

J'ai contourné cela en stockant ces valeurs dans des variables tableaux, mais, du coup, je ne vois plus l'intérêt d'un module de classe...

Ma question : n'y a t'il pas un moyen de calculer une fois pour toutes les valeurs des propriétés que je créée?

Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Bonjour,

Désolé pour la stupidité de ma question à propos des propriétés dans le module de classe. Je ne devais vraiment pas être réveillé...

Bon, voici l'état d'avancement de mon projet.

J'ai modifié le code initial pour :
- ajouter un "effet" léger sur le mouvement afin "d'arrondir" les déplacements.
- faire en sorte de pouvoir lancer plusieurs dés.

Pour cela, il nous faut :
- 1 userform dans lequel vous dessinez : 1 Frame (Frame1), un Bouton de commande (CommandButton1) et autant d'image que de dés souhaités (Image1, Image2, Image3... Si vous changez le nom des Images, conservez le préfixe : "Image")
- 1 module "standard" (Module1)
- 1 module de classe (Classe1).

Les codes :
Dans le module de l'UserForm :
Option Explicit

Private Declare Function GetInputState Lib "user32" () As Long

Private Arret As Boolean, Nb_Des As Integer

Private Sub UserForm_Initialize()
Dim Ctrl As Control
  With Me
    .Caption = ""
    .Width = 400
    .Height = 400
  End With
  With Frame1
    .Caption = ""
    .BorderStyle = fmBorderStyleSingle
    .Move 0, 0, Me.Width - 4, Me.Height - 21
  End With
  For Each Ctrl In Me.Controls
    If Ctrl.Name Like "Image*" Then
        Nb_Des = Nb_Des + 1
        ReDim Preserve mesImages(1 To Nb_Des)
        Ctrl.Visible = False
        Set mesImages(Nb_Des).ImagesEvents = Ctrl
    End If
  Next Ctrl
  CommandButton1.Caption = "Maintenez pour calculer la force du lancer"
  Randomize Timer
End Sub

Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim sens As Integer, Cpt As Integer
  
  Arret = False
  sens = 1
  For Cpt = 1 To Nb_Des
    With Me.Controls("Image" & Cpt)
      .Move CInt(((Me.Width - 1) * Rnd()) + 1), CInt(((Me.Width - 1) * Rnd()) + 1), 25, 25
      .Visible = False
    End With
  Next Cpt
  CommandButton1.Caption = "Relachez pour lancer le dé"
  Me.Repaint
  pasGeneral = 1
  
  Do
    If pasGeneral = 200 Or pasGeneral = 0 Then sens = sens * -1
    pasGeneral = pasGeneral + (1 * sens)
    If GetInputState And Not Arret Then
      DoEvents
    End If
  Loop Until Arret = True
End Sub
Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim Cpt As Integer
  Arret = True ' pour interrompre la boucle
  For Cpt = 1 To Nb_Des
    Calcul_Coeff Cpt
    Me.Controls("Image" & Cpt).Visible = True
  Next
  Lancer
End Sub


Sub Lancer()
 Dim sens As Integer, cogneH As Boolean, cogneV As Boolean, deb As Double, posH As Double, posV As Double, Quoi As String, Cpt As Integer
 Dim NumAutresDes() As Integer, i As Integer, k As Integer, Sortie As Integer
 ReDim Preserve NumAutresDes(Nb_Des - 2)
  With Me
    .CommandButton1.Visible = False
    .Caption = "Dé lancé..."
    Do
      For Cpt = 1 To Nb_Des
        'temps de pause
        deb = Timer
        Do While Timer - deb < 0.04
        Loop
      
        If Abs(mesImages(Cpt).coef_X) > Abs(mesImages(Cpt).coef_Y) Then mesImages(Cpt).effetVertical = False Else mesImages(Cpt).effetVertical = True
        If mesImages(Cpt).effetVertical = True Then
          mesImages(Cpt).coef_X = mesImages(Cpt).coef_X + mesImages(Cpt).effet
        Else
          mesImages(Cpt).coef_Y = mesImages(Cpt).coef_Y + mesImages(Cpt).effet
        End If
        'calcul de la position du dé posH = Left, posV = Top
        posH = .Controls("Image" & Cpt).Left + mesImages(Cpt).pas * mesImages(Cpt).coef_X
        posV = .Controls("Image" & Cpt).Top + mesImages(Cpt).pas * mesImages(Cpt).coef_Y
        'Stocke le numéro des autres dés pour voir s'ils ne s'entrechoquent pas)
        k = 0
        For i = 1 To Nb_Des
          If i <> Cpt Then
            NumAutresDes(k) = i
            k = k + 1
          End If
        Next
        'En fonction de la position, regarde si le dé touche les bords ou un autre dé
        If Cogne(posH, posV, Quoi) = True Then
          'Si le dé rencontre un obstacle => change le sens
          ChangeDirection Cpt, Quoi
        End If
        If Entrechoque(posH, posV, NumAutresDes, Quoi) = True Then 'GoTo Fin
            ChangeDirection Cpt, Quoi
        End If
        If mesImages(Cpt).pas > 2 Then
            .Controls("Image" & Cpt).Move posH, posV
            mesImages(Cpt).pas = mesImages(Cpt).pas * 0.98  ' on ralentit peu à peu le déplacement, de manière générale
            .Repaint
        End If
      Next Cpt
      'Si le pas de toutes les images est < 2 => sortie de boucle
      Sortie = 0
      For Cpt = 1 To Nb_Des
        If mesImages(Cpt).pas < 2 Then Sortie = Sortie + 1
      Next Cpt
      If Sortie = Nb_Des Then Exit Do
    Loop
    .CommandButton1.Visible = True
    .CommandButton1.Caption = "Maintenez pour calculer la force du lancer"
    .Caption = "Relancez le dé..."
  End With
End Sub

Function Cogne(posH As Double, posV As Double, Quoi As String) As Boolean
Dim Cpt As Integer

Cogne = False
For Cpt = 1 To Nb_Des
  Select Case posH
    Case Is <= 0: posH = 0: Cogne = True: Quoi = "Obstacle vertical"
    Case Is >= Me.Frame1.Width - Me.Controls("Image" & Nb_Des).Width: posH = Me.Frame1.Width - Me.Controls("Image" & Nb_Des).Width: Cogne = True: Quoi = "Obstacle vertical"
  End Select
  Select Case posV
    Case Is <= 0: posV = 0: Cogne = True: Quoi = "Obstacle horizontal"
    Case Is >= Me.Frame1.Height - Me.Controls("Image" & Nb_Des).Height: posV = Me.Frame1.Height - Me.Controls("Image" & Nb_Des).Height: Cogne = True: Quoi = "Obstacle horizontal"
  End Select
Next
End Function

Function Entrechoque(posH As Double, posV As Double, NumAutresDes() As Integer, Quoi As String) As Boolean
'A REALISER : lorsque deux dés se touchent...
End Function

Sub ChangeDirection(Num As Integer, Quoi As String)
  Select Case Quoi
    Case "Obstacle vertical"
      mesImages(Num).coef_X = -mesImages(Num).coef_X ' on inverse alors le sens
    Case "Obstacle horizontal"
      mesImages(Num).coef_Y = -mesImages(Num).coef_Y ' on inverse alors le sens
  End Select
  mesImages(Num).pas = mesImages(Num).pas * 0.6 ' ralentissement additionnel du fait du choc
  mesImages(Num).effetVertical = Not mesImages(Num).effetVertical
  mesImages(Num).effet = -mesImages(Num).effet
End Sub


Dans le module "standard :
Public mesImages() As New Classe1
Public pasGeneral As Double


Public Sub Calcul_Coeff(NumImage As Integer)
Dim Valeurs(), i As Long
  ReDim Preserve Valeurs(200)
  For i = -100 To 100
    Valeurs(i + 100) = i / 100
  Next i
  'calcul aléatoire de Coeff_X
  mesImages(NumImage).coef_X = Valeurs(CInt((199 * Rnd()) + 1))
  mesImages(NumImage).coef_Y = Valeurs(CInt((199 * Rnd()) + 1))
  If Abs(mesImages(NumImage).coef_X) > Abs(mesImages(NumImage).coef_Y) Then
    mesImages(NumImage).effet = mesImages(NumImage).coef_X / 30
    mesImages(NumImage).effetVertical = False
  Else
    mesImages(NumImage).effet = mesImages(NumImage).coef_Y / 30
    mesImages(NumImage).effetVertical = True
  End If
  mesImages(NumImage).pas = pasGeneral + CInt((19 * Rnd()) + 1)
End Sub


Dans le Module de classe :
Option Explicit

Public WithEvents ImagesEvents As MSForms.Image

Public coef_X As Double
Public coef_Y As Double
Public effet As Double
Public effetVertical As Boolean
Public pas As Double


Il me reste donc à faire :
- La fonction Entrechoque (deux dés qui se heurtent),
- Changer les propriétés Picture des contrôles Images afin d'afficher de vrais dés...

Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Bonjour,

Petit retour en arrière pour "mettre au propre" le projet.
Il y a maintenant la possibilité de placer plusieurs "joueurs".
Le code est mieux "ordonné", plus rangé, les variables plus explicites etc...

Mais... Je rencontre bug sur bug pendant les tests et je n'arrive pas à déterminer de ou cela peut provenir...
Pas de message d'erreur, si ce n'est : Ne réponds pas... et je suis obligé de couper Excel "sauvagement".

Si l'un d'entre vous peut y jeter un oeil...

Alors, le fichier doit être composé de :
- 1 UserForm (name : Piste) sur lequel vous dessinez : 1 Frame (name : Frame1) et des CommandButton (j'ai testé jusque 4) et des Images (Name Image*) (j'ai testé jusque 5)
Le nombre de boutons détermine le nombre de joueurs, le nombre d'images détermine le nombre de dés...
- 1 Module
- 2 Modules de classe : Classe_Boutons et Classe_Dé

Les codes :
UserForm :
Option Explicit


Private Sub UserForm_Initialize()
  Dim ctrControl As Control
  Dim intIndic As Integer

  'Initialisation des variables publiques
  Set objBtn = Nothing
  dblPasGeneral = 1
  intNb_Des = 0
  intNb_Joueurs = 0
  Erase bytVal_Prec
  
'MISE EN FORME (esthétique)
  'UserForm
  With Piste
    .Caption = ""
    .Width = 400
    .Height = 400
  End With
  'Frame1
  With Frame1
    .Caption = ""
    .BorderStyle = fmBorderStyleSingle
    .BackColor = 32768
    .Move 0, 0, Piste.Width - 4, Piste.Height - 21
  End With
  
  'Boucle sur les contrôles pour en faire des instances de nos classes
  For Each ctrControl In Piste.Controls
    'Evite un bug dans la Sub Lancer avec CInt(Ctrl.Tag)
    ctrControl.Tag = 0
    'Si le contrôle a pour propriété Name : Image*
    '(préfixe Image, valable pour Image1, Image2, Image_Dé_1 etc, non valide pour Imag1 par exemple)
    If ctrControl.Name Like "Image*" Then
      'MISE EN FORME (esthétique)
      With ctrControl
        .Width = 40
        .Height = 40
        .Visible = False
        .PictureSizeMode = fmPictureSizeModeStretch
      End With
      'on comptabilise le nombre de dés
      intNb_Des = intNb_Des + 1
      ReDim Preserve Dé(1 To intNb_Des)
      'On créé notre "Objet" Dé dans la Classe_Dé
        'cf déclaration de variable dans le Module : Public Dé() As New Classe_Dé
        'cf : Module de Classe Classe_Dé
      Set Dé(intNb_Des).ImagesEvents = ctrControl
      'Dimensionnement de la variable tableau bytVal_Prec
        'cette variable va stocker la valeur précédente de chacun des dés
        'pour pouvoir la passer en paramètre de la propriété Valeur des dés (cf Module Classe_Dé)
      ReDim Preserve bytVal_Prec(intNb_Des - 1)
      'Attribution des valeurs initiales à chacune des propriétés du dé
      Paramétrage_Dés ctrControl, intNb_Des
      Placement_Dés ctrControl, intNb_Des
      
    ElseIf ctrControl.Name Like "CommandButton*" Then 'Si le contrôle a pour propriété Name CommandButton*
      'on comptabilise le nombre de joueurs
      intNb_Joueurs = intNb_Joueurs + 1
      ReDim Preserve Boutons(1 To intNb_Joueurs)
      Set Boutons(intNb_Joueurs).BoutonsEvents = ctrControl
      ctrControl.Tag = intNb_Joueurs
      ctrControl.Caption = "Joueur " & intNb_Joueurs
      ctrControl.Move 0, 0, 60, 24
      'on ne laisse affiché que le bouton Joueur 1
      If intNb_Joueurs > 1 Then ctrControl.Visible = False
    End If
    
  Next ctrControl
  'initialisation du générateur de nombre aléatoire
  Randomize Timer
  'Joueur "en cours" = Joueur 1
  intJoueurEncours = 1
  
End Sub


Module :
Option Explicit

Public Dé() As New Classe_Dé
Public Boutons() As New Classe_Boutons

Public objBtn As Object
Public bytVal_Prec() As Byte
Public dblPasGeneral As Double
Public intNb_Des As Integer, intNb_Joueurs As Integer, intJoueurEncours As Integer

Sub Paramétrage_Dés(Ctrl As Control, Num As Integer)
  Dim Tb(200) As Double, i As Integer
  
    Dé(Num).Nom = Ctrl.Name
    Dé(Num).Cote = Ctrl.Width
    'Les propriétés coef_X et coef_Y sont des valeurs
    'comprises entre -1 et 1 Step 0.01
    For i = -100 To 100
      Tb(i + 100) = i / 100
    Next i
    'Calcul aléatoire des coef X et Y
    Dé(Num).coef_X = Tb(CInt((199 * Rnd()) + 1))
    Dé(Num).coef_Y = Tb(CInt((199 * Rnd()) + 1))
    'le pas de chaque dé peut être différent à peu de variante tout de même
    Dé(Num).pas = dblPasGeneral + CInt((19 * Rnd()) + 1)
    'calcul de la valeur initiale du dé
    'La valeur précédente du dé doit être passée en paramètre,
    '(à part pour la valeur initiale...)
    'Donc nous la stockons dans une variable tableau
    bytVal_Prec(Num - 1) = Dé(Num).Valeur(0)
    
End Sub

Sub Placement_Dés(Ctrl As Control, Num As Integer)
'sans importance pour le moment
  Ctrl.Move 40 * Num, 40 * Num
End Sub

Sub Lancer()
  Dim deb As Double, posH As Double, posV As Double
  Dim Cpt As Integer, Sortie As Integer, intScore As Integer
  Dim Quoi As String, strMsg As String
  Dim Tab_Dés_Choc() As Integer
  Dim Ctrl As Control
  
    With Piste
      Do
        For Cpt = 1 To intNb_Des
          'temps de pause
          deb = Timer
          Do While Timer - deb < 0.04
          Loop
          'calcul de la position du dé posH = Left, posV = Top
          posH = Dé(Cpt).Gauche + Dé(Cpt).pas
          posV = Dé(Cpt).Haut + Dé(Cpt).pas
          'En fonction de la position, regarde si le dé touche les bords ou un autre dé
          If Cogne(posH, posV, Quoi, Cpt) = True Then
            'Si le dé rencontre un obstacle => change le sens
            ChangeDirection Cpt, Quoi
          End If
          If Dé(Cpt).pas > 2 Then
            .Controls(Dé(Cpt).Nom).Move posH, posV
            bytVal_Prec(Cpt - 1) = Dé(Cpt).Valeur(bytVal_Prec(Cpt - 1))
            .Controls(Dé(Cpt).Nom).Picture = LoadPicture(ThisWorkbook.Path & "\" & bytVal_Prec(Cpt - 1) & ".gif")
            Dé(Cpt).pas = Dé(Cpt).pas * 0.5  ' on ralentit peu à peu le déplacement, de manière générale
            .Repaint
          End If
        Next Cpt
        'Si le pas de tous les dés est < 2 => sortie de boucle
        Sortie = 0
        For Cpt = 1 To intNb_Des
          If Dé(Cpt).pas < 2 Then Sortie = Sortie + 1
        Next Cpt
        If Sortie = intNb_Des Then Exit Do
      Loop
      'Affiche le score dans le Caption de l'UserForm
      For Cpt = LBound(bytVal_Prec) To UBound(bytVal_Prec)
        strMsg = strMsg & bytVal_Prec(Cpt) & " + "
        intScore = intScore + bytVal_Prec(Cpt)
      Next Cpt
      strMsg = Left(strMsg, Len(strMsg) - 2) & "= " & intScore
      .Caption = .Caption & " Score : " & strMsg
    End With
    
    'Affiche le bouton du joueur suivant
    intJoueurEncours = intJoueurEncours + 1
    If intJoueurEncours = 5 Then intJoueurEncours = 1
    For Each Ctrl In Piste.Controls
      If CInt(Ctrl.Tag) = intJoueurEncours Then Ctrl.Visible = True: Exit For
    Next
    
End Sub

Function Cogne(posH As Double, posV As Double, Quoi As String, Lequel As Integer) As Boolean
  Dim Cpt As Integer

    Cogne = False
    Select Case posH
      Case Is <= 0: posH = 0: Cogne = True: Quoi = "Obstacle vertical"
      Case Is >= Piste.Frame1.Width - Dé(Lequel).Cote: posH = Piste.Frame1.Width - Dé(Lequel).Cote: Cogne = True: Quoi = "Obstacle vertical"
    End Select
    Select Case posV
      Case Is <= 0: posV = 0: Cogne = True: Quoi = "Obstacle horizontal"
      Case Is >= Piste.Frame1.Height - Dé(Lequel).Cote: posV = Piste.Frame1.Height - Dé(Lequel).Cote: Cogne = True: Quoi = "Obstacle horizontal"
    End Select

End Function

Sub ChangeDirection(Num As Integer, Quoi As String)

  Select Case Quoi
    Case "Obstacle vertical"
      Dé(Num).coef_X = -Dé(Num).coef_X ' on inverse alors le sens
    Case "Obstacle horizontal"
      Dé(Num).coef_Y = -Dé(Num).coef_Y ' on inverse alors le sens
  End Select
    Dé(Num).pas = Dé(Num).pas * 0.6 ' ralentissement additionnel du fait du choc
  
End Sub


Module de Classe Classe_Boutons :
Option Explicit

Private Declare Function GetInputState Lib "user32" () As Long

Public WithEvents BoutonsEvents As MSForms.CommandButton

Dim blnArret As Boolean

Public Sub BoutonsEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim sens As Integer, Cpt As Integer

    'Initialisation des variables
      'blnArret => permet de quitter la boucle Do Loop ci dessous
      '         en relachant le clic de souris (événement MouseUp)
      'sens => le "pas" de chaque dé est une valeur comprise entre 0 et 150
      '         sens permet de varier de 0 à 150 puis de 150 à 0
    blnArret = False
    sens = 1
  
    'Placement initial de chacun des dés
    For Cpt = 1 To intNb_Des
      With Piste.Controls(Dé(Cpt).Nom)
        .Move CInt(((Piste.Width - 1) * Rnd()) + 1), CInt(((Piste.Width - 1) * Rnd()) + 1), 25, 25
        .Visible = False
      End With
    Next Cpt
    
    Piste.Caption = BoutonsEvents.Caption
    Piste.Repaint
    'calcul du pas général, tant que le joueur appuie sur le bouton
    dblPasGeneral = 50
    Do
      blnArret = True
      If dblPasGeneral = 150 Or dblPasGeneral = 49 Then sens = sens * -1 '"oscille entre 50 et 150
      dblPasGeneral = dblPasGeneral + (1 * sens)
      If GetInputState And Not blnArret Then
        DoEvents
      End If
    Loop Until blnArret = True
    
End Sub
Public Sub BoutonsEvents_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim Cpt As Integer

    blnArret = True ' pour interrompre la boucle
    For Cpt = 1 To intNb_Des
      Piste.Controls(Dé(Cpt).Nom).Visible = True
      Piste.Controls(Dé(Cpt).Nom).Picture = LoadPicture(ThisWorkbook.Path & "\" & bytVal_Prec(Cpt - 1) & ".gif")
    Next
  
    BoutonsEvents.Visible = False
    Call Lancer
    
    'paramètres des dés du joueur suivant
    For Cpt = 1 To intNb_Des
      Paramétrage_Dés Piste.Controls(Dé(Cpt).Nom), Cpt
    Next Cpt
    
End Sub


Module de classe Classe_Dé
Option Explicit

Public WithEvents ImagesEvents As MSForms.Image

Public Nom As String
Public Cote As Double
Public coef_X As Double
Public coef_Y As Double
Public pas As Double

Property Get Gauche() As Double
  Gauche = ImagesEvents.Left
End Property

Property Get Haut() As Double
  Haut = ImagesEvents.Top
End Property

Property Get Droite() As Double
  Droite = Gauche + Cote
End Property

Property Get Bas() As Double
  Bas = Haut + Cote
End Property

Property Get Valeur(ValeurPrec As Byte) As Byte
  If ValeurPrec = 0 Then
    Valeur = CInt((5 * Rnd()) + 1)
  Else
    Do
      Valeur = CInt((5 * Rnd()) + 1)
    Loop While Valeur = ValeurPrec And Valeur = 7 - ValeurPrec
  End If
End Property


EDIT : Il vous faudra également les images des dés : http://cjoint.com/?DJbpsV7P0q7


🎼 Cordialement,
Franck 🎶
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Bonjour,

J'ai trouvé l'erreur (youpi) mais ne me l'explique pas (ooohhh)...

Pour la période de tests, et afin "d'accélérer" le mouvement, j'ai décidé, d'un commun accord avec moi-même, de diminuer le pas plus franchement.
J'ai donc remplacé le 0.98 initialement prévu par ucfout par 0.5 ici :
Dé(Cpt).pas = Dé(Cpt).pas * 0.5  ' on ralentit peu à peu le déplacement, de manière générale

Ben du coup, ça plante Excel, obligé d'arrêter le processus (Ctrl+Alt+Suppr)...
En remettant :
Dé(Cpt).pas = Dé(Cpt).pas * 0.98

ça n'a plus l'air de planter. En tout cas, le plantage n'est plus systématique...
Verriez vous pourquoi, afin que je me couche moins bête ce soir???
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Bonjour,
déjà : pas adroit d'utiliser select case pour changer de sens, puisque select case quittera au premier cas rencontré.
Quid alors si cogne à la fois verticalement et horizontalement ? Ton select case ne changera qu'un seul des deux sens.
Utilise plutôt deux conditions If ( sans elseif)
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Bonjour,

Merci. Je n'avais pas étudié ce cas...
Il faut donc que je revois les deux fonctions "Cogne" et "ChangeDirection" pour leur passer en paramètre, au lieu de Quoi As String, QuoiV As String et QuoiH As String. Ceci me permettra de gérer le cas ou le dé est dans un coin de la piste.
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Venons-en maintenant, Franck, à ton histoire de plantage dénoncée plus haut et pour laquelle tu cherchjes une explication.
Regarde ce que tu fais :
Tu calcules si débordement et inverses alors le sens.
Que se passe-t-il alors, surtout lorsque le "pas" est devenu petit :
- tu as déjà "débordé". Imaginons que tu aies beaucoup débordé. Tu reviens en arrière, mais tu as déjà réduit le pas, ce qui fait que tu peux dans certains cas (surtout si tu as considérablement réduit le pas) rester en débordement ===>> et ton code, tel qu'écrit, va provoquer un nouveau changement de sens (et cette fois-ci : dans le mauvais sens).
- ce n'est pas ce qu'il convient de fair(e.
Il faut aller dans cet ordre :
1) calculer la position qui résulterait de l'avancement (sans encore modifier la position)
2) si cette position "théorique" conduit à un"débord" :
a) la corriger d'abord
b) appliquer la position (non corrigée si non débord ou corrigée si débord)
c) changer le sens et décider du ralentissement éventuel

C'est le mécanisme que j'ai appliqué (voir plus haut) dans mon message du 21 sept. 2014 à 18:11

NB : tu as moins de problèmes avec 0.98 qu'avec 0.5 pour cette raison même. Puisqu'en divisant le pas par deux, tu as beaucoup plus de chances, après débord, de rester en débord !
Mais même avec 0.98, tu risques de te retrouver dans un cas de figure identique à un moment ou l'autre, si "pas de bol" !
Applique ce que je t'ai dit (mon code du 21 sept. 2014 à 18:11 ) et tu seras à l'abri de cet aléa.
Messages postés
18038
Date d'inscription
lundi 7 décembre 2009
Statut
Modérateur
Dernière intervention
11 avril 2018
226
Pour le cas où mes explications seraient trop brouillonnes :
Imagine que, faisant un pas, tu arrives à 1 cm d'une frontière et que ton pas suivant est de 100 cms ==>> tu vas de trouver à 99 cms de l'autre côté de la frontière. Si, à partir de cette nouvelle position, tu fais un pas de 95 cms en arrière, tu ne vas pas traverser à nouveau la frontière.

Si par contre, avant même de faire ton second pas (celui de 100 cms), tu détermines qu'il te ferait passer de l'autre côté et décide de le corriger de sorte à rester à la limite de ton propre côté, ton prochain pas en arrière se fera forcément dans TA zone, quelle que puisse être la longueur de ce pas.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Salut Ucfoutu,

Une fois de plus merci.
Je pense avoir bien compris mais en fait, j'applique déjà cette solution depuis le 21 septembre et ton message.
La fonction Cogne n'a pas changée depuis :
Function Cogne(posH As Double, posV As Double, Quoi As String, Lequel As Integer) As Boolean
  Dim Cpt As Integer
    Cogne = False
    Select Case posH
      'ici, si le pas nous a conduit à un débort (même de 300cms), la position revient sur le bord gauche
      Case Is <= 0: posH = 0: Cogne = True: Quoi = "Obstacle vertical"
      'Idem pour le bord droit
      Case Is >= Piste.Frame1.Width - Dé(Lequel).Cote: posH = Piste.Frame1.Width - Dé(Lequel).Cote: Cogne = True: Quoi = "Obstacle vertical"
    End Select
'Idem pour haut et bas
    Select Case posV
      Case Is <= 0: posV = 0: Cogne = True: Quoi = "Obstacle horizontal"
      Case Is >= Piste.Frame1.Height - Dé(Lequel).Cote: posV = Piste.Frame1.Height - Dé(Lequel).Cote: Cogne = True: Quoi = "Obstacle horizontal"
    End Select
End Function


Bon le souci est, semble t'il réglé, mais je ne me l'explique pas.

De plus, le souci était vraiment le plantage en règle d'Excel. Cela ne devrait pas se produire, même si j'ai 18 dés en dehors de ma piste.

Je vais poster le code actuel pour que vous puissiez suivre l'avancement et apporter d'éventuelles corrections et/ou suggestions.
Aujourd'hui (si j'en ai le temps), je me lance dans l'aventure du choc entre x dés.

Merci encore.

ps : je t'envoie également un MP pour notre autre sujet.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Bonjour tout le monde,

Voici l'avancement du code. J'essaie de commenter un maximum, mais je dois être encore un peu confus dans mes explications...
J'ai écarté l'idée d'avancer avec un seul pas au profit d'un avancement en fonction de 2 paramètres coef_X et coef_Y (abscisse et ordonnée) auxquels vient s'ajouter la force du jet (calculée au maintien du clic sur le bouton).
J'ai également considéré l'emplacement du joueur et calculé coef_X et coef_Y en fonction de deux points : l'endroit du "tir" et l'endroit de chute du dé. Vous verrez, j'ai fait un dessin ;-)

- 1 Userform (Name : Piste), 1 Frame (Frame1), autant de CommandButton que de joueurs, autant d'Image (Name : Image*) que de dés souhaités.
Son code :
Option Explicit

Private Sub UserForm_Initialize()
  Dim ctrControl As Control
  Dim intIndic As Integer

  'Initialisation des variables publiques
  Set objBtn = Nothing
  intForce = 1
  intNb_Des = 0
  intNb_Joueurs = 0
  Erase bytVal_Prec
  Erase G
  Erase T
  
'MISE EN FORME (esthétique)
  'UserForm
  With Piste
    .Caption = ""
    .Width = 400
    .Height = 400
  End With
  'Frame1
  With Frame1
    .Caption = ""
    .BorderStyle = fmBorderStyleSingle
    .BackColor = 32768
    .Move 0, 0, Piste.Width - 4, Piste.Height - 21
  End With
  
  'Boucle sur les contrôles pour en faire des instances de nos classes
  For Each ctrControl In Piste.Controls
    'Evite un bug dans la Sub Lancer avec CInt(Ctrl.Tag)
    ctrControl.Tag = 0
    'Si le contrôle a pour propriété Name : Image*
    '(préfixe Image, valable pour Image1, Image2, Image_Dé_1 etc, non valide pour Imag1 par exemple)
    If ctrControl.Name Like "Image*" Then
      'MISE EN FORME (esthétique)
      With ctrControl
        .Width = 32
        .Height = 32
        .Visible = False
        .PictureSizeMode = fmPictureSizeModeStretch
      End With
      'on comptabilise le nombre de dés
      intNb_Des = intNb_Des + 1
      ReDim Preserve Dé(1 To intNb_Des)
      'On créé notre "Objet" Dé dans la Classe_Dé
        'cf déclaration de variable dans le Module : Public Dé() As New Classe_Dé
        'cf : Module de Classe Classe_Dé
      Set Dé(intNb_Des).ImagesEvents = ctrControl
      'Dimensionnement de la variable tableau bytVal_Prec
        'cette variable va stocker la valeur précédente de chacun des dés
        'pour pouvoir la passer en paramètre de la propriété Valeur des dés (cf Module Classe_Dé)
      ReDim Preserve bytVal_Prec(intNb_Des - 1)
      'Attribution des valeurs initiales à certaines des propriétés du dé
      Dé(intNb_Des).Nom = ctrControl.Name
      Dé(intNb_Des).Cote = ctrControl.Width
    ElseIf ctrControl.Name Like "CommandButton*" Then 'Si le contrôle a pour propriété Name CommandButton*
      'on comptabilise le nombre de joueurs
      intNb_Joueurs = intNb_Joueurs + 1
      ReDim Preserve Boutons(1 To intNb_Joueurs)
      Set Boutons(intNb_Joueurs).BoutonsEvents = ctrControl
      ctrControl.Tag = intNb_Joueurs
      ctrControl.Caption = "Joueur " & intNb_Joueurs
      ctrControl.Move 0, 0, 60, 24
      'on ne laisse affiché que le bouton Joueur 1
      If intNb_Joueurs > 1 Then ctrControl.Visible = False
    End If
    
  Next ctrControl
  'initialisation du générateur de nombre aléatoire
  Randomize Timer
  'Joueur "en cours" = Joueur 1
  intJoueurEncours = 1
  
End Sub


- 1 Module :
Le code (je vous ai laissé les dessins...) :
Option Explicit

Public Dé() As New Classe_Dé
Public Boutons() As New Classe_Boutons

Public objBtn As Object
Public bytVal_Prec() As Byte, G() As Integer, T() As Integer
Public Tir_X As Double, Tir_Y As Double
Public intForce As Integer, intNb_Des As Integer, intNb_Joueurs As Integer, intJoueurEncours As Integer, LancerDe As Integer

Sub Paramétrage_Dés(Ctrl As Control, Num As Integer)
  Dim i As Integer, BienPlace As Boolean
  
  Dé(Num).Nom = Ctrl.Name
  Dé(Num).Cote = Ctrl.Width
  'calcul de la valeur initiale du dé
  'La valeur précédente du dé doit être passée en paramètre,
  '(à part pour la valeur initiale...)
  'Donc nous la stockons dans une variable tableau
  bytVal_Prec(Num - 1) = Dé(Num).Valeur(0)
  
  'le premier endroit ou apparaissent les dés est fonction de
  'l'endroit duquel le joueur jette les dés. Il est choisit aléatoirement
  'parmi 8 possibilités :
  '         1         2         3
  '            ---------------
  '           |               |
  '           |               |
  '         8 |     piste     | 4
  '           |               |
  '           |               |
  '            ---------------
  '         7         6         5
  'Le 1er dé (Num = 1) est celui qui détermine l'aire de retombée des autres, puisque,
  'dans un même lancer, les dés ne "tombent" pas aux 4 coins de la piste. On considère
  'que l'aire de retombée occupe une surface valant 1/4 de la piste totale
  ' aire pour 1 :        aire pour 2 :        aire pour 3 :       etc...
  '    ---------------      ---------------      ---------------
  '   |       |       |    |   |      |    |    |       |       |
  '   |   1   |       |    |   |  2   |    |    |       |    3  |
  '   |-------|       |    |   |------|    |    |       |-------|
  '   |               |    |               |    |               |
  '   |               |    |               |    |               |
  '    ---------------      ---------------      ---------------
  
  'La direction que va suivre le dé dépend :
    'de l'endroit de tir
    'de l'endroit de chute
  'Avec ces deux points connus, nous pouvons déterminer les propriétés coef (X et Y) de nos dés
  'Nous venons de voir le point de chute, il nous manque de point de tir.
  'Exemple pour la position 1 :
  'On va choisir un endroit aléatoire sur la ligne qui part du 1 :
  '         1---------2         3
  '            ---------------
  '           |               |
  '           |               |
  '         8 |     piste     | 4
  '           |               |
  '           |               |
  '            ---------------
  '         7         6         5
  'exemple pour le 2 :                  exemple pour le 3 :         exemple pour le 4 :         etc...
  '         1         2---------3        1         2         3        1         2         3
  '            ---------------              ---------------  |           ---------------
  '           |               |            |               | |          |               |
  '           |               |            |               | |          |               |
  '         8 |     piste     | 4        8 |     piste     | 4        8 |     piste     | 4
  '           |               |            |               |            |               | |
  '           |               |            |               |            |               | |
  '            ---------------              ---------------              ---------------  |
  '         7         6         5        7         6         5        7         6         5
  
  'Si c'est le 1er dé , on détermine de ou lance le joueur
  If Num = 1 Then
    LancerDe = CInt((7 * Rnd()) + 1)
    'Détermination du point exact d'ou est lancé le dé
    Select Case LancerDe
      Case 1: Tir_X = CInt(Piste.Frame1.Width / 2 * Rnd()): Tir_Y = -(Piste.Frame1.Height / 4)  '0 < Tir X < 200 ; Y fixe
      Case 2: Tir_X = CInt(Piste.Frame1.Width / 2 * Rnd() + Piste.Frame1.Width / 2): Tir_Y = -(Piste.Frame1.Height / 4) '200 < Tir X < 400 ; Y fixe
      Case 3: Tir_X = Piste.Frame1.Width + Piste.Frame1.Width / 4: Tir_Y = CInt(Piste.Frame1.Height / 2 * Rnd()) 'Tir X fixe ; 0 < Tir Y < 200
      Case 4: Tir_X = Piste.Frame1.Width + Piste.Frame1.Width / 4: Tir_Y = CInt(Piste.Frame1.Height / 2 * Rnd() + Piste.Frame1.Height / 2) 'X fixe ; 200 < Tir Y < 400
      Case 5: Tir_X = CInt(Piste.Frame1.Width / 2 * Rnd() + Piste.Frame1.Width / 2): Tir_Y = Piste.Frame1.Height + Piste.Frame1.Height / 4 '200 < X < 400 ; Y Fixe
      Case 6: Tir_X = CInt(Piste.Frame1.Width / 2 * Rnd()): Tir_Y = Piste.Frame1.Height + Piste.Frame1.Height / 4 '0 < X < 200 ; Y Fixe
      Case 7: Tir_X = -(Piste.Frame1.Width / 4): Tir_Y = CInt(Piste.Frame1.Height / 2 * Rnd() + Piste.Frame1.Height / 2) 'X fixe ; 200 < Tir Y < 400
      Case 8: Tir_X = -(Piste.Frame1.Width / 4): Tir_Y = CInt(Piste.Frame1.Height / 2 * Rnd()) 'Tir X fixe ; 0 < Tir Y < 200
    End Select
  End If
  'Pour éviter la superposition de deux dés, il nous faut regarder les propriétés Left
  '(G()) et Top (T())(déclarées en public) de tous les dés déjà lancés... ou pas!
  ReDim Preserve G(Num)
  ReDim Preserve T(Num)
  Do
    BienPlace = True
    Select Case LancerDe
      Case 1: G(Num) = CInt(Piste.Frame1.Width / 2 * Rnd()): T(Num) = CInt(Piste.Frame1.Height / 2 * Rnd()) 'propriétés Left et top entre 0 et 200
      Case 2: G(Num) = CInt(Piste.Frame1.Width / 2 * Rnd + Piste.Frame1.Width / 4): T(Num) = CInt(Piste.Frame1.Height / 2 * Rnd()) ' 100 < Left < 300 et 0 < top < 200
      Case 3: G(Num) = CInt(Piste.Frame1.Width / 2 * Rnd + Piste.Frame1.Width / 2 - Dé(Num).Cote): T(Num) = CInt(Piste.Frame1.Height / 2 * Rnd()) ' 160 < Left < 360 et 0 < top < 200
      Case 4: G(Num) = CInt(Piste.Frame1.Width / 2 * Rnd + Piste.Frame1.Width / 2 - Dé(Num).Cote): T(Num) = CInt(Piste.Frame1.Height / 2 * Rnd + Piste.Frame1.Height / 4) ' 160 < Left < 360 et 100 < top < 300
      Case 5: G(Num) = CInt(Piste.Frame1.Width / 2 * Rnd + Piste.Frame1.Width / 2 - Dé(Num).Cote): T(Num) = CInt(Piste.Frame1.Height / 2 * Rnd + Piste.Frame1.Height / 2 - Dé(Num).Cote) ' 160 < Top et Left < 360
      Case 6: G(Num) = CInt(Piste.Frame1.Width / 2 * Rnd + Piste.Frame1.Width / 4): T(Num) = CInt(Piste.Frame1.Height / 2 * Rnd + Piste.Frame1.Height / 2 - Dé(Num).Cote) ' 100 < Left < 300 et 160 < top < 360
      Case 7: G(Num) = CInt(Piste.Frame1.Width / 2 * Rnd()): T(Num) = CInt(Piste.Frame1.Height / 2 * Rnd + Piste.Frame1.Height / 2 - Dé(Num).Cote) '0 < Left < 200 et 160 < top < 360
      Case 8: G(Num) = CInt(Piste.Frame1.Width / 2 * Rnd()): T(Num) = CInt(Piste.Frame1.Height / 2 * Rnd + Piste.Frame1.Height / 4) ' 0 < Left < 200 et 100 < top < 300
    End Select
    'A partir du second dé, il faut éviter le chevauchement :
    If Num > 1 Then
      For i = 1 To Num - 1 'on boucle sur les dés déjà tirés
        'on compare leurs côtés gauches respectifs
        If G(Num) >= G(i) And G(Num) <= G(i) + Dé(Num).Cote Or G(Num) < G(i) And G(Num) + Dé(Num).Cote > G(i) Then
          'Et on compare leur Top...
          If T(Num) >= T(i) And T(Num) <= T(i) + Dé(Num).Cote Or T(Num) < T(i) And T(Num) + Dé(Num).Cote > T(i) Then BienPlace = False: Exit For
        End If
      Next i
    End If
  'On boucle tant que le dé est mal placé!
  Loop While BienPlace = False
  'On place le dé
  Ctrl.Move G(Num), T(Num)
  'Ctrl.Visible = False
  'calcul des coef_X et coef_Y
  Dé(Num).coef_X = G(Num) - Tir_X
  Dé(Num).coef_Y = T(Num) - Tir_Y

End Sub

Sub Lancer()
  Dim deb As Double, posH As Double, posV As Double
  Dim Cpt As Integer, Sortie As Integer, intScore As Integer
  Dim QuoiH As String, QuoiV As String, strMsg As String
  Dim Tab_Dés_Choc() As Integer
  Dim Ctrl As Control
  
    With Piste
    
      Do
          Sortie = 0
          For Cpt = 1 To intNb_Des
              '********************************** petit temps de pause
              deb = Timer
              Do While Timer - deb < 0.04
              Loop
              
              '********************************* positionnement
              'calcul de la position du dé posH = Left, posV = Top
              posH = Dé(Cpt).Gauche + Dé(Cpt).coef_X
              posV = Dé(Cpt).Haut + Dé(Cpt).coef_Y
              
              '********************************* Cogne contre un bord de la piste
              'En fonction de la position, regarde si le dé touche les bords de la piste
              QuoiV = ""
              QuoiH = ""
              If Cogne(posH, posV, QuoiH, QuoiV, Cpt) = True Then
                  'Si le dé rencontre un obstacle => change le sens
                  ChangeDirection Cpt, QuoiH, QuoiV
              End If
              
              '********************************* Entrechoc de deux dés
              
              
              '********************************* Déplacement du dé
              'pas calculé en faisant la racine carrée de la somme des carrés des 2 côtés d'un triangle...
              If Sqr(Dé(Cpt).coef_X ^ 2 + Dé(Cpt).coef_Y ^ 2) > 2 Then
                  .Controls(Dé(Cpt).Nom).Move posH, posV 'déplacement
                  bytVal_Prec(Cpt - 1) = Dé(Cpt).Valeur(bytVal_Prec(Cpt - 1)) 'calcul valeur
                  'affichage de l'image en fonction de la valeur
                  .Controls(Dé(Cpt).Nom).Picture = LoadPicture(ThisWorkbook.Path & "\" & bytVal_Prec(Cpt - 1) & ".gif")
                  ' on ralentit peu à peu le déplacement, de manière générale
                  Dé(Cpt).coef_X = Dé(Cpt).coef_X * 0.8
                  Dé(Cpt).coef_Y = Dé(Cpt).coef_Y * 0.8
                  .Repaint
              Else
                  Sortie = Sortie + 1
              End If
          Next Cpt
          
          'Si le "pas" de tous les dés est < 2 => sortie de boucle
          If Sortie = intNb_Des Then Exit Do
          
      Loop
      
      
      'Affiche le score dans le Caption de l'UserForm
      For Cpt = LBound(bytVal_Prec) To UBound(bytVal_Prec)
        strMsg = strMsg & bytVal_Prec(Cpt) & " + "
        intScore = intScore + bytVal_Prec(Cpt)
      Next Cpt
      strMsg = Left(strMsg, Len(strMsg) - 2) & "= " & intScore
      .Caption = .Caption & " Score : " & strMsg
    End With
    
    'Affiche le bouton du joueur suivant
    intJoueurEncours = intJoueurEncours + 1
    If intJoueurEncours > intNb_Joueurs Then intJoueurEncours = 1
    For Each Ctrl In Piste.Controls
      If CInt(Ctrl.Tag) = intJoueurEncours Then Ctrl.Visible = True: Exit For
    Next

End Sub

Function Cogne(posH As Double, posV As Double, QuoiH As String, QuoiV As String, Lequel As Integer) As Boolean
'En fonction de la position, regarde si le dé touche les bords de la piste
  Dim Cpt As Integer

    Cogne = False
    Select Case posH
      Case Is <= 0: posH = 0: Cogne = True: QuoiH = "Obstacle vertical"
      Case Is >= Piste.Frame1.Width - Dé(Lequel).Cote: posH = Piste.Frame1.Width - Dé(Lequel).Cote: Cogne = True: QuoiH = "Obstacle vertical"
    End Select
    Select Case posV
      Case Is <= 0: posV = 0: Cogne = True: QuoiV = "Obstacle horizontal"
      Case Is >= Piste.Frame1.Height - Dé(Lequel).Cote: posV = Piste.Frame1.Height - Dé(Lequel).Cote: Cogne = True: QuoiV = "Obstacle horizontal"
    End Select

End Function

Sub ChangeDirection(Num As Integer, QuoiH As String, QuoiV As String)
'Si le dé rencontre un obstacle => change le sens

  If QuoiH = "Obstacle vertical" Then Dé(Num).coef_X = -Dé(Num).coef_X ' on inverse alors le sens horizontalement
  If QuoiV = "Obstacle horizontal" Then Dé(Num).coef_Y = -Dé(Num).coef_Y ' on inverse alors le sens verticalement
  Dé(Num).coef_X = Dé(Num).coef_X * 0.6 ' ralentissement additionnel du fait du choc
  Dé(Num).coef_Y = Dé(Num).coef_Y * 0.6
  
End Sub


- 2 Modules de classe :
Classe_Boutons :
Private Declare Function GetInputState Lib "user32" () As Long

Public WithEvents BoutonsEvents As MSForms.CommandButton

Dim blnArret As Boolean

Public Sub BoutonsEvents_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim sens As Integer, Cpt As Integer

    'Initialisation des variables
      'blnArret => permet de quitter la boucle Do Loop ci dessous
      '         en relachant le clic de souris (événement MouseUp)
      'sens => la force du lancer est une valeur comprise entre 0 et 50
      '         sens permet de varier de 0 à 50 puis de 50 à 0
    blnArret = False
    sens = 1
    'paramètres des dés du joueur suivant
    For Cpt = 1 To intNb_Des
      Paramétrage_Dés Piste.Controls(Dé(Cpt).Nom), Cpt
      Piste.Controls(Dé(Cpt).Nom).Visible = False
    Next Cpt

    Piste.Caption = BoutonsEvents.Caption
    Piste.Repaint
    'calcul de la force du lancer, tant que le joueur appuie sur le bouton
    intForce = 1
    Do
      blnArret = True
      If intForce = 50 Or intForce = 0 Then sens = sens * -1 '"oscille" entre 0 et 50
      intForce = intForce + (1 * sens)
      'Permet de ne déclencher le DoEvents que si l'utilisateur fait une action
      'en l'occurence lacher le bouton de la souris
      If GetInputState And Not blnArret Then
        DoEvents 'permet de laisser faire l'événement MouseUp
      End If
    Loop Until blnArret = True
    
End Sub
Public Sub BoutonsEvents_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim Cpt As Integer

    blnArret = True ' pour interrompre la boucle
    For Cpt = 1 To intNb_Des
      'On applique la force aux deux coefficients de déplacement des dés :
      If Dé(Cpt).coef_X < 0 Then Dé(Cpt).coef_X = Dé(Cpt).coef_X - intForce Else Dé(Cpt).coef_X = Dé(Cpt).coef_X + intForce
      If Dé(Cpt).coef_Y < 0 Then Dé(Cpt).coef_Y = Dé(Cpt).coef_Y - intForce Else Dé(Cpt).coef_Y = Dé(Cpt).coef_Y + intForce
      'On affiche nos dés
      Piste.Controls(Dé(Cpt).Nom).Visible = True
      'On charge l'image correspondant à leur valeur
      Piste.Controls(Dé(Cpt).Nom).Picture = LoadPicture(ThisWorkbook.Path & "\" & bytVal_Prec(Cpt - 1) & ".gif")
    Next
    'On masque le bouton de commande du joueur en cous
    BoutonsEvents.Visible = False
    'et on lance les dés (cf Module...)
    Call Lancer
    
End Sub


Classe_Dé :
Option Explicit
'propriétés des images de dés

Public WithEvents ImagesEvents As MSForms.Image

Public Nom As String 'Name
Public Cote As Double 'Width (=Height)
Public coef_X As Double 'déplacement horizontal du dé
Public coef_Y As Double 'déplacement vertical du dé

Property Get Gauche() As Double 'Left
  Gauche = ImagesEvents.Left
End Property

Property Get Haut() As Double 'Top
  Haut = ImagesEvents.Top
End Property

Property Get Droite() As Double 'Right
  Droite = Gauche + Cote
End Property

Property Get Bas() As Double 'Bottom
  Bas = Haut + Cote
End Property

Property Get Valeur(ValeurPrec As Byte) As Byte 'Value
  If ValeurPrec = 0 Then
    Valeur = CInt((5 * Rnd()) + 1)
  Else
    Do
      Valeur = CInt((5 * Rnd()) + 1)
    Loop While Valeur = ValeurPrec And Valeur = 7 - ValeurPrec
  End If
End Property
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Ps : je n'ai pas remis le zip des images des dés, il est toujours dispo ci-dessus.
Messages postés
12177
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
26 juin 2020
12
Re-Bonjour,

Besoin d'un appui, non pas technique, mais de bon sens...

Êtes vous d'accord avec cette analyse du choc entre x dés :

S'il y a choc, il faut distinguer plusieurs cas :
Cas 1 : Les dés vont dans la même direction ou presque
=> le dé heurté accélère légèrement mais continue dans la même direction
=> le dé qui heurte ralentit et change légèrement de direction, mais toujours dans le même sens
Cas 2 : les dés vont dans des directions opposées
=> les deux dés ralentissent et changent de sens

Seconde question : cette analyse, si elle est juste pour 2 dés, l'est-elle également pour 3, 4 ou plus de dés???

Merci par avance