Soyez le premier à donner votre avis sur cette source.
Vue 8 863 fois - Téléchargée 589 fois
Option Explicit Dim Ind(3, 1) As Variant 'de 0 à 3 index clignotant et 2eme dim pr stocker la couleur Dim Damier(107, 1) As Integer 'On stock la position des cases pour faciliter le calcul Dim First As Boolean 'Indique qu'on vient de lancer le jeu Dim Fin As Boolean 'Indique que le jeu est terminé 'Ouverture de l'application Private Sub Form_Load() Randomize 'Activation de la fonction permettant d'avoir des chiffres aléatoire Dim i As Integer Dim j As Integer Dim k As Integer Dim ran As Integer k = 0 'Index du carré dont sont issus tous les autres First = True: Fin = False Left = (Screen.Width - Width) / 2 ' on centre la fenetre sur la gauche Top = (Screen.Height - Height) / 2 'et en hauteur For j = 0 To 11 'k = 0 1 2 3 4 5 6 7 8 For i = 0 To 8 ' 9 10 11 12 13 14 15 16 17 Damier(k, 0) = i 'On stock la position des cases pour faciliter le calcul Damier(k, 1) = j If ((i <> 0) Or (j <> 0)) Then 'On passe la 1ere case qui existe par défaut Load Img(k) 'création de chaque bouton de la grille Img(k).Visible = True 'on les rend visibles et on les place Img(k).Left = 400 * (i) 'abscisse Img(k).Top = 400 * (j) 'ordonnée ran = CInt(Rnd * 3) + 1 'choix d'un chiffre entre 0 et 3 (+1) Select Case ran Case 1: Img(k).BackColor = vbRed Case 2: Img(k).BackColor = vbBlue Case 3: Img(k).BackColor = vbGreen Case 4: Img(k).BackColor = RGB(255, 127, 0) 'Orange End Select k = k + 1 'case suivante Else k = k + 1 'case suivante End If Next i Next j InitClick End Sub 'Gestion du click sur une case Private Sub Img_Click(Index As Integer) Dim i As Integer Dim j As Integer Dim c As Integer 'Indique qu'on a bien un rectangle If Fin = False Then 'Si ce n'est pas la fin du jeu on permet le click First = False: c = 0 For i = 0 To 3 If Active(Index) = False Then 'Si on a pas encore cliqué sur cette case If Ind(i, 0) = 200 Then Ind(i, 0) = Index 'On récupère l'index qui a été cliqué pour le faire clignoter Ind(i, 1) = Img(Index).BackColor 'On récupère a couleur de la case If i = 3 Then 'Si c'est le 4eme carré qu'on choisi alors on vérifie si la couleur identique For j = 1 To 3 If (Ind(j, 1) = Ind(0, 1)) Then c = c + 1 'couleur identique Next j If c = 3 Then 'Si on les mm couleurs alors on rectangle si c'est un rectangle Rectangle 'fonction vérifiant si c'est un rectangle Else InitClick 'alors on réinitialise le choix des cases End If Else 'Sinon on quitte la boucle Exit For 'On quitte la boucle End If End If Else 'Si on a déjà cliqué sur cette case, on la réinitialise If (Ind(i, 0) = Index) Then Img(Ind(i, 0)).BackColor = Ind(i, 1) 'On redonne la couleur d'origine Ind(i, 0) = 200 'Initialisation des index nb 200 arbitraire Ind(i, 1) = vbBlack 'On réinitialise en noire la couleur de la case nulle InitClick 'On réinitialise tout Exit For End If End If Next i End If End Sub 'On relance une nouvelle partie Private Sub New_Click() Randomize Dim k, i, j, ran As Integer Fin = False k = 0 'Index du carré dont sont issus tous les autre For j = 0 To 11 'k = 0 1 2 3 4 5 6 7 8 For i = 0 To 8 ' 9 10 11 12 13 14 15 16 17 ran = CInt(Rnd * 3) + 1 'choix d'un chiffre entre 0 et 3 (+1) Select Case ran Case 1: Img(k).BackColor = vbRed Case 2: Img(k).BackColor = vbBlue Case 3: Img(k).BackColor = vbGreen Case 4: Img(k).BackColor = RGB(255, 127, 0) 'Orange End Select k = k + 1 'case suivante Next i Next j InitClick Me.Score = "0" Me.Bar.Width = 1300 End Sub 'Permet de faire clignoter les cases toutes les 1/2 secondes - 500ms Private Sub Timer_Timer() Dim i As Integer For i = 0 To 3 If Ind(i, 0) <> 200 Then If Img(Ind(i, 0)).BackColor <> vbWhite Then Img(Ind(i, 0)).BackColor = vbWhite 'Blanc Else Img(Ind(i, 0)).BackColor = Ind(i, 1) 'Couleur originale End If End If Next i 'Animation de la progress bar du temps 'Environ 60s width = 1300 'Pour augmenter le temps de réponse, changez l'interval ou réduisez moins vite la progress bar If ((Me.Bar.Width - 10) <= 0) Then Me.Bar.Width = 0 Fin = True MsgBox "Le temps imparti est terminé" InitClick Else Me.Bar.Width = Me.Bar.Width - 10 End If End Sub 'On vérifie si on a bien un rectangle Private Sub Rectangle() Dim a As Integer Dim b As Integer Dim c As Integer Dim i As Integer a = 0: b = 0 'On check si un coin existe For i = 1 To 3 'Si' l'un des x est égal au premier If (Damier(Ind(i, 0), 1) = Damier(Ind(0, 0), 1)) Then a = a + 1 'abcisse If (Damier(Ind(i, 0), 0) = Damier(Ind(0, 0), 0)) Then a = a + 1 'ordonnée Next i If a = 2 Then 'Si on a trouvé un coin de rectangle alors 'On check si un 2eme coin exite For i = 1 To 3 'on check si une des cases est opposée au coin a If ((Damier(Ind(i, 0), 0) <> Damier(Ind(0, 0), 0)) And (Damier(Ind(i, 0), 1) <> Damier(Ind(0, 0), 1))) Then c = Ind(i, 0) 'On garde l'index qui est opposé pour la vérification End If Next i For i = 1 To 3 'on check si une des cases est opposée au coin a If ((Damier(Ind(i, 0), 0) <> Damier(Ind(0, 0), 0)) And (Damier(Ind(i, 0), 1) <> Damier(Ind(0, 0), 1))) Then c = i 'On garde l'index qui est opposé pour la vérification End If Next i For i = 1 To 3 'on check si une des cases est opposée au coin a If (c <> i) Then 'Si on est pas sur le coin opposé à ind(0,0) If (Damier(Ind(i, 0), 1) = Damier(Ind(c, 0), 1)) Then b = b + 1 'abcisse If (Damier(Ind(i, 0), 0) = Damier(Ind(c, 0), 0)) Then b = b + 1 'ordonnée End If Next i End If If ((a = 2) And (b = 2)) Then 'Alors on a un rectangle ou un carré Regeneration Else 'Alors on a cliqué sur 4 carrés de la mm couleur mais ne formant pas un rectangle InitClick 'On réinitialise les clicks End If End Sub 'Vérifie si on a déjà cliqué sur cette case Private Function Active(Index) As Boolean Dim i As Integer Active = False For i = 0 To 3 'Si on a une égalité alors on a déjà cliqué dessus If (Ind(i, 0) = Index) Then Active = True: Exit For Next i End Function 'On met de nouvelle couleur dans la zone validée Private Sub Regeneration() 'a b Randomize 'c d Dim ran As Integer Dim Coins(3, 1) As Integer 'on détermine les 4 coins du carré Dim i, j, x1, x2, x3, x4, y1, y2, y3, y4, a, b, k As Integer x1 = 10: y1 = 20 'a x4 = 0: y4 = 0 'a 'Recherche du point a(x1,y1) For i = 0 To 3 If ((Damier(Ind(i, 0), 0) <= x1) And (Damier(Ind(i, 0), 1) <= y1)) Then x1 = Damier(Ind(i, 0), 0) y1 = Damier(Ind(i, 0), 1) a = Ind(i, 0) 'on récupère le coin a End If Next i 'Recherche du point b(x2,y2) For i = 0 To 3 'Si c'est sur la mm hauteur que a mais que ce n'est pas lui mm If ((Damier(Ind(i, 0), 1) = y1) And (Damier(Ind(i, 0), 0) <> x1)) Then x2 = Damier(Ind(i, 0), 0) 'on stock la position de b pour calculer la surface et sa position y2 = Damier(Ind(i, 0), 1) 'et hauteur de b End If Next i 'Recherche du point d(x4,y4) For i = 0 To 3 'le coin opposé n'a rien en commun avec x1 et y1 If ((Damier(Ind(i, 0), 0) <> x1) And (Damier(Ind(i, 0), 1) <> y1)) Then x4 = Damier(Ind(i, 0), 0) y4 = Damier(Ind(i, 0), 1) End If Next i 'Recherche du point c(x3,y3) For i = 0 To 3 'S'il a la mm hauteur que le coin opposé mais que ce n'est pas lui mm évidemment If ((Damier(Ind(i, 0), 1) = y4) And (Damier(Ind(i, 0), 0) <> x4)) Then x3 = Damier(Ind(i, 0), 0) y3 = Damier(Ind(i, 0), 1) End If Next i 'Calcul du score nb de cases fois 6 'largeur * hauteur * 6 Me.Score = CStr(CInt(Me.Score.Text) + (((x4 - x1) + 1) * ((y4 - y1) + 1) * 6)) InitClick 'On réinitialise les clicks k = a 'on fait partir le compteur du coin en haut à gauche b = 0 'on compte le nombre de ligne de la zone cliquée 'On récupère le rectangle trouvé et on change la couleur de ses cases For j = y1 To y4 For i = x1 To x4 ran = CInt(Rnd * 3) + 1 'choix d'un chiffre entre 0 et 3 (+1) While ran = SearchColor(k) 'Tant qu'on a la mm couleur on en cherche une autre ran = CInt(Rnd * 3) + 1 'choix d'un chiffre entre 0 et 3 (+1) Wend Select Case ran Case 1: Img(k).BackColor = vbRed Case 2: Img(k).BackColor = vbBlue Case 3: Img(k).BackColor = vbGreen Case 4: Img(k).BackColor = RGB(255, 127, 0) 'Orange End Select k = k + 1 Next i b = b + 1 'On incrémente la ligne 'On change de ligne, donc on part de la position du clic en haut à gauche + 9 * nb de ligne k = a + (9 * b) 'Voir k dans form_load Next j End Sub 'Initialisation du tableau qui stocke les 4 choix qui compose le rectangle choisit Private Sub InitClick() Dim i As Integer For i = 0 To 3 'On redonne la couleur de la case stockée If First = False Then If Ind(i, 0) <> 200 Then Img(Ind(i, 0)).BackColor = Ind(i, 1) End If Ind(i, 0) = 200 'Initialisation des index nb 200 arbitraire Ind(i, 1) = vbBlack 'On réinitialise en noire la couleur de la case nulle Next i End Sub 'Recherche d'une couleur différente de celle d'origine Private Function SearchColor(k) As Integer Select Case Img(k).BackColor Case vbRed: SearchColor = 1 Case vbBlue: SearchColor = 2 Case vbGreen: SearchColor = 3 Case RGB(255, 127, 0): SearchColor = 4 End Select End Function
30 juin 2008 à 20:00
Et merci pour tes conseils avisés...
30 juin 2008 à 18:16
4 points c'est 4 points. un carré, un losange, un rectangle, un parallélogramme, ...
un rectangle c'est une MÊME surface dont les 4 coins forment chacun un angle droit, ce qui est le cas avec une droite par la nature de tes points formés par des carrés...
c'est donc bien un problème de compréhension ou d'explication (je te laisse le choix), il n'y a pas de bug
le code n'est pas optimisé (dommage dans ce cas de ne pas avoir de notion objet) mais par chance il est abondamment commenté, et la jouabilité est correcte :)
plus qu'à travailler un peu le graphisme, sauver les scores, quelques sons, historique du "plus gros score en un coup", niveaux des parties (difficile pour un tableau aléatoire mais çà peut jouer sur... le temps de la partie, la nuance des couleurs moins marquée, etc...) et çà peut devenir pas mal
30 juin 2008 à 17:54
On doit trouver 4 coins d'un rectangle de la mm couleur
Et c'est EXACTEMENT ce que l'on a sur ton lien.
a b => G0 H0
c d => G7 H7
on a bien (a, b) et (c, d) sur le mm axe des abcisses et
on a bien (a, c) et (b, d) sur le mm axe des ordonnées.
Ce qui au final donne forcément un rectangle ou un carré.
Où est le pb? en quoi ce n'est pas un rectangle? On a bien 4 angles droits, non? Peut être que la règle n'est pas très explicite sur ce point... en tout cas, vous me rassurez, votre "bug" n'est en faite, qu'une mauvaise compréhension de la règle. je tacherais de la reformuler.
Merci pour vos commentaires en tout cas.
30 juin 2008 à 15:30
si je sélectionne juste 2 "lignes de 2 cases" qui sont sur le même axe, çà n'est pas pour autant un rectangle de la même couleur...
et pourtant
http://www.monsterup.com/upload/1214832546.jpg
30 juin 2008 à 15:19
même pour un rectangle de A1 à F2 par exemple, Sechaud et moi devions cliquer sur toutes les cases, par exemple A1 B1 C1 D1, au lieu de A1 F1 F2 A2. dans ce 2 cas çà fonctionne ^^
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.