JEU DE REFLEXION ET D'ENTRAINEMENT OCULAIRE

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

Télécharger le zip

30 juin 2008 20:13:11 :

Reformulation de la règle du jeu.