begin process at 2012 02 16 11:43:47
  Trouver un code source :
 
dans
 
Accueil > 

Code

 > 

VBA

 > DÉMINEUR SOUS EXCEL

DÉMINEUR SOUS EXCEL


 Information sur la source

Note :
Aucune note
Catégorie :VBA Niveau :Débutant Date de création :16/08/2002 Date de mise à jour :16/08/2002 15:06:58 Vu / téléchargé :8 879 / 533

Auteur : SuperClic

Ecrire un message privé
Commentaire sur cette source (0)
Ajouter un commentaire et/ou une note

 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

  • 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
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



 Fichier Zip

Les Membres Club peuvent télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !
  • Demineur.xlsTélécharger ce fichier [Réservé aux membres club]34 816 octets

Télécharger le zip


 Sources du même auteur

LISTER LES PROCESSUS ACTIFS AVEC LES API
TROUVER L'IP D' UN SITE INTERNET AVEC L 'API WINSOCK
Source avec Zip S' AMUSER AVEC LES LECTEURS CD (BUG CORRIGÉ)
CRÉATION OU MODIFICATION DE RACCOURCI (COMPATIBLE VBS)

 Sources de la même categorie

Source avec Zip Source avec une capture OUTLOOK ATTACHEMENT SAVER par MoiLafouine
Source avec Zip GESTION PERSONNEL par oudlarbi
Source avec Zip Source avec une capture CALENDRIER EN VBA POUR EXCEL 2010 par nounou94
Source avec Zip Source avec une capture MANIPULER LES FENETRES ENFANT D'EXCEL par bigfish_le vrai
Source avec Zip Source avec une capture COLLECTION ID par Le Pivert

Commentaires et avis

Aucun commentaire pour le moment.

 Ajouter un commentaire




Nos sponsors


Sondage...

Comparez les prix

CalendriCode

Février 2012
LMMJVSD
  12345
6789101112
13141516171819
20212223242526
272829    

Consulter la suite du CalendriCode

Photothèque

 
Développement réalisé par Nicolas SOREL (Nix) avec l'aide de : Cyril DURAND et Emmanuel (EBArtSoft), Merci à Vincent pour ses précieux conseils.
CodeS-SourceS.com© Toute reproduction même partielle est interdite sauf accord écrit du Webmaster
CodeS-SourceS.com© est une marque déposée tous droits réservés

Google Coop CodeS-SourceS Google Coop CodeS-SourceS
Temps d'éxécution de la page : 0,374 sec (4)

Nous contacter | Annoncer sur CodeS-SourceS | Mentions légales