'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
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)
Piste.Height : 700 - Piste.ImageDe.Height : 24Ce qui, logiquement est correct. Mon dé ne devrait passer dépasser le cadre de l'UserForm.
De_Top : 676
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
Do While StopIt = Falsecar il est de nature à torturer indûment ton processeur.
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
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
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
Attendre 0.05 'attente de 5 centièmes de secondes
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionPrivate Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)et dans un Module :
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
Private der As Double, cpt As LongLa variable cpt n'est là que pour simuler et visualiser une "action"
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
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
Private Declare Function GetInputState Lib "user32" () As LongQue fait-il ?
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
Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)Laz textbox atteint ainsi parfaitement les deux côtés, d'une part.
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
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
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
Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)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
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
Public mesImages() As New Classe1
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
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
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
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
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
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
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
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
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
Dé(Cpt).pas = Dé(Cpt).pas * 0.5 ' on ralentit peu à peu le déplacement, de manière générale
Dé(Cpt).pas = Dé(Cpt).pas * 0.98
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
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
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
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
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
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