Démineur sous excel

Télécharger le projet
Commenter

Description

Le programme suivant permet de faire un démineur sur Excel.
Pour régénerer le démineur, faut pas oublier de rajouter un bouton (commandbutton1) sur la feuille.

Source / Exemple : 


Dim mineX(15), mineY(15), Hdep, carre, etat
Sub efface()

For i = 1 To 10
    Rows(i).Value = ""
Next i

End Sub

Private Sub CommandButton1_Click()

etat = 1
carre = 0
Cells(7, 17) = carre
Hdep = Timer
Call efface

Randomize Timer
For i = 1 To 15
creat:
    Do: mineX(i) = Int(Rnd * 10): Loop Until mineX(i) <> 0
    Do: mineY(i) = Int(Rnd * 10): Loop Until mineY(i) <> 0
    For test = 1 To 15
        If mineX(test) = mineX(i) And mineY(test) = mineY(i) And i <> test Then GoTo creat
    Next test
Next i
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If ActiveCell.Row < 11 And ActiveCell.Column < 11 And etat = 1 Then

If ActiveCell.Value = "0" Then ActiveCell.Font.ColorIndex = 5
If ActiveCell.Value = "1" Then ActiveCell.Font.ColorIndex = 3
If ActiveCell.Value = "2" Then ActiveCell.Font.ColorIndex = 9

End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ActiveCell.Row < 11 And ActiveCell.Column < 11 And etat = 1 Then

For i = 1 To 15
    If ActiveCell.Row = mineY(i) And ActiveCell.Column = mineX(i) Then GoTo perdue
Next i

carre = carre + 1
Cells(7, 17) = carre
If carre >= 85 Then GoTo gagne

ActiveCell.Value = compte(ActiveCell.Row, ActiveCell.Column)

GoTo fin
perdue:
etat = 0
Call affiche
MsgBox "Perdu ! "
GoTo fin
gagne:
temps = Int((Timer - Hdep) * 100) / 100
MsgBox "Bravo ! Gagné en " + CStr(temps) + " secondes"
fin:

End If
End Sub
Sub affiche()
For i2 = 1 To 15
    Cells(mineY(i2), mineX(i2)).Value = "+"
Next i2
End Sub

Function compte(Ligne, Colonne)
nb = 0
For i = 1 To 15
    If Ligne = mineY(i) And Colonne = mineX(i) + 1 Then nb = nb + 1
    If Ligne = mineY(i) And Colonne = mineX(i) - 1 Then nb = nb + 1
    If Ligne = mineY(i) + 1 And Colonne = mineX(i) Then nb = nb + 1
    If Ligne = mineY(i) + 1 And Colonne = mineX(i) + 1 Then nb = nb + 1
    If Ligne = mineY(i) + 1 And Colonne = mineX(i) - 1 Then nb = nb + 1
    If Ligne = mineY(i) - 1 And Colonne = mineX(i) Then nb = nb + 1
    If Ligne = mineY(i) - 1 And Colonne = mineX(i) + 1 Then nb = nb + 1
    If Ligne = mineY(i) - 1 And Colonne = mineX(i) - 1 Then nb = nb + 1
Next i
compte = nb
End Function

Sub CréationFeuille()
'
' CréationFeuille Macro
' Macro enregistrée le 16/08/2002 par mps
' Cette sub sert uniquement a créer la feuille

'
    Range("A1:J10").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Range("Q6").Select
    ActiveCell.FormulaR1C1 = "Cases parcourues :"
    Range("Q6:W6").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("T7").Select
    ActiveCell.FormulaR1C1 = "/ 85"
    Range("T7:W7").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("Q7:S7").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("Q6:W7").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Cells.Select
    Selection.ColumnWidth = 1.6
    Range("M1").Select
End Sub
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (SuperClic)