Bombes_source

Bombes (P)03/2010 MyLzz59: le Code Source Complet
(à coller dans la zone de code de la première feuille)

' -----------------
' Zone Déclarations
' -----------------
Const Tit = "Bombes (P)03/2010 MyLzz59"
Const Ym = 30, Xm = 40, Nb = 100, Xt = 2, Xb = 18, Xc = 28, Xr = 32
'Dim P() As Integer

' ------------------
' EVT: Teste la Zone
' ------------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Y = Target.Row: X = Target.Column: Cancel = True
If Y = Ym + 2 And X = Xr Then
    If MsgBox("Réinitialiser l'Aire de Jeu ?", _
        vbQuestion + vbYesNo + vbDefaultButton2, Tit) = vbYes Then Remplis
    Exit Sub
End If
If X < 1 Or X > Xm Or Y < 1 Or Y > Ym Then Exit Sub
Prot False: Pop Y, X: TesteGagne: Prot True
End Sub

' ------------
' EVT: Drapeau
' ------------
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Y = Target.Row: X = Target.Column: If X < 1 Or X > Xm Or Y < 1 Or Y > Ym Then Exit Sub
Select Case Target.Text
    Case "": T = 10: T2 = -1: GoSub SS1
    Case "O": T = 11: T2 = 1: GoSub SS1
End Select
Cancel = True: Exit Sub
SS1: Prot False: Colorie Y, X, 1 * T: Cells(Ym + 2, Xb) = Cells(Ym + 2, Xb) + T2
If PP(Y, X) = 9 Then Cells(Ym + 6, Xb) = Cells(Ym + 6, Xb) + T2
Cells(Ym + 2, Xc) = Cells(Ym + 2, Xc) + T2: TesteGagne: Prot True: Return
End Sub

' -----------------------
' Crée un Nouveau Terrain
' -----------------------
Sub Remplis()
Randomize Timer
'ReDim P(1 To Ym, 1 To Xm)
Prot False
Cells(Ym + 5, 1).Value = "Z" + String$(Xm * Ym, "0")
Range(Cells(1, 1), Cells(Ym, Xm)).Interior.ColorIndex = 15
Range(Cells(1, 1), Cells(Ym, Xm)).ClearContents ' Nettoyage
For T = 1 To Nb
    'Do: Y = Int(Rnd * Ym) + 1: X = Int(Rnd * Xm) + 1: Loop While P(Y, X) = 9 ' Bombes
    Do: Y = Int(Rnd * Ym) + 1: X = Int(Rnd * Xm) + 1: Loop While PP(Y, X) = 9 ' Bombes
    For Y2 = Y - 1 To Y + 1: For X2 = X - 1 To X + 1
        If X2 >= 1 And X2 <= Xm And Y2 >= 1 And Y2 <= Ym Then
            If X2 <> X Or Y2 <> Y Then
                'If P(Y2, X2) < 9 Then P(Y2, X2) = P(Y2, X2) + 1 ' Incrément autour
                If PP(Y2, X2) < 9 Then PP(Y2, X2) = PP(Y2, X2) + 1 ' Incrément autour
            Else
                'P(Y, X) = 9 ' Place Bombe
                PP(Y, X) = 9 ' Place Bombe
            End If
        End If
    Next X2, Y2
Next T
Cells(Ym + 2, Xt).Value = Tit: Cells(Ym + 2, Xb).Value = Nb
Cells(Ym + 2, Xc).Value = Xm * Ym: Cells(Ym + 6, Xb).Value = Nb 'Marquages
Prot True: MsgBox "Bonne Chance ;)", vbInformation, Tit
End Sub

' ----------------------------------
' SUB: Découvrir une Case (Récursif)
' ----------------------------------
Sub Pop(ByVal Y As Integer, ByVal X As Integer)
If X < 1 Or X > Xm Or Y < 1 Or Y > Ym Then Exit Sub
If Cells(Y, X).Text <> "" Then Exit Sub
'Colorie Y, X, P(Y, X): Cells(Ym + 2, Xc) = Cells(Ym + 2, Xc) - 1
Colorie Y, X, PP(Y, X): Cells(Ym + 2, Xc) = Cells(Ym + 2, Xc) - 1
'Select Case P(Y, X)
Select Case PP(Y, X)
Case 9 ' Bombe
    ' --
    For Y = 1 To Ym: For X = 1 To Xm
        'If Cells(Y, X).Text = "" _
            or  Cells(Y, X).Text = "O" Then Colorie Y, X, P(Y, X)
        If Cells(Y, X).Text = "" _
            Or Cells(Y, X).Text = "O" Then Colorie Y, X, PP(Y, X)
        If Cells(Y, X).Text = "0" Then Colorie Y, X, 13
    Next X, Y
    MsgBox "<<<< BOOM >>>>" + vbCrLf + vbCrLf + "Vous avez perdu.. :(", vbCritical, Tit
    ' --
Case 1 To 8 ' Découvrir
Case 0 ' Découvrir en Récursif
    For Y2 = Y - 1 To Y + 1: For X2 = X - 1 To X + 1
        If X2 >= 1 And X2 <= Xm And Y2 >= 1 And Y2 <= Ym Then
            If Cells(Y2, X2).Text = "" Then Pop Y2, X2
        End If
    Next X2, Y2
End Select
End Sub

' --------------
' Sub TesteGagne
' --------------
Sub TesteGagne()
If Cells(Ym + 2, Xb).Value = Cells(Ym + 2, Xc).Value Or _
    (Cells(Ym + 2, Xb).Value = 0 And Cells(Ym + 6, Xb).Value = 0) Then
    For Y = 1 To Ym: For X = 1 To Xm
        'If Cells(Y, X).Text = "" _
            or  Cells(Y, X).Text = "O" Then Colorie Y, X, P(Y, X)
        If Cells(Y, X).Text = "" _
            Or Cells(Y, X).Text = "O" Then Colorie Y, X, PP(Y, X)
        If Cells(Y, X).Text = "0" Then Colorie Y, X, 12
    Next X, Y
    MsgBox "<<<< BRAVO >>>>" + vbCrLf + vbCrLf + "Vous avez gagné.. :)", vbInformation, Tit
End If
End Sub


' -----------------------------------------------------------------------------
' Sub: Colorie la Case (Y,X) en Fonction du Nombre de Bombes (ou autre..)
' ( N=0..8 ; N=9:Bombe ; N=10:Drapeau ; N=11:Cachée ; N=12:Gagné ; N=13:Perdu )
' -----------------------------------------------------------------------------
Sub Colorie(ByVal Y As Integer, ByVal X As Integer, ByRef N As Integer)
If X < 1 Or X > Xm Or Y < 1 Or Y > Ym Or N < 0 Or N > 13 Then Exit Sub
With Cells(Y, X)
    .Interior.ColorIndex = IIf(N = 13, 30, IIf(N = 12, 10, _
        IIf(N = 11, 15, IIf(N = 10, 19, IIf(N = 9, 3, IIf(N, 17, 16))))))
    .Font.ColorIndex = IIf(N = 13, 30, IIf(N = 12, 10, _
        IIf(N = 11, 11, IIf(N = 10, 11, IIf(N = 9, 1, IIf(N, 8, 16))))))
    .Font.Name = IIf(N > 8 And N < 11, "Wingdings", "Comic Sans")
    .Value = IIf(N > 11, "0", IIf(N = 11, "", IIf(N = 10, "O", IIf(N = 9, "M", CStr(N)))))
End With
End Sub

' -------------------
' SUB: Protéger (O/N)
' -------------------
Sub Prot(B As Boolean)
If B Then Sheets(1).Protect "" Else Sheets(1).Unprotect ""
End Sub

' ---------------------------------------------------------------------
' Property Let: simule l'Ecriture de N [Integer] dans PP(Y,X) [Integer]
' ---------------------------------------------------------------------
Property Let PP(ByVal Y As Integer, ByVal X As Integer, ByRef N As Integer)
If X < 1 Or X > Xm Or Y < 1 Or Y > Ym Or N < 0 Or N > 9 Then Exit Property
Z$ = Cells(Ym + 5, 1).Value
Mid$(Z$, Xm * (Y - 1) + X + 1, 1) = CStr(N)
Cells(Ym + 5, 1).Value = Z$
End Property

' ---------------------------------------------------------------------
' Property Get: simule la Lecture de N [Integer] dans PP(Y,X) [Integer]
' ---------------------------------------------------------------------
Property Get PP(ByVal Y As Integer, ByVal X As Integer) As Integer
If X < 1 Or X > Xm Or Y < 1 Or Y > Ym Or N < 0 Or N > 9 Then PP = -1: Exit Property
PP = Val(Mid$(Cells(Ym + 5, 1).Value, Xm * (Y - 1) + X + 1, 1))
End Property

-MyLzz59-

Bombes_MeF

Bombes (P)03/2010 MyLzz59: le Code Générateur de l'Interface
(ne sert qu'en préliminaire, pour bâtir la feuille)

Sub MeF_Jeu_Bombes()
'On Error Resume Next
Application.DisplayAlerts = False
While Sheets.Count > 1: Sheets(Sheets.Count).Delete: Wend
Sheets(1).Activate: Sheets(1).Name = "Bombes"
With Cells
    .ColumnWidth = 0: .RowHeight = 0
    '.EntireColumn.Hidden = True: .EntireRow.Hidden = True
End With
With Range("A1:AO34")
    .ColumnWidth = 2.14: .RowHeight = 14.25
    '.EntireRow.Hidden = False: .EntireColumn.Hidden = False
    .Font.Name = "Comic Sans MS": .Font.Size = 9
    .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
    .Interior.Pattern = xlSolid: .Interior.ColorIndex = 15
End With
Application.Goto Reference:="R1C1:R34C41"
Rows("31:31").RowHeight = 3: Rows("33:33").RowHeight = 3
With Rows("31:33")
    .Font.Bold = True: .Interior.Pattern = xlSolid: .Interior.Color = 8388736
End With
Rows("34:34").RowHeight = 0.75: Columns("AO:AO").ColumnWidth = 0.08
With ActiveWindow
    .SplitRow = 33: .SplitColumn = 40: .FreezePanes = True
End With
LS = xlContinuous: WE = xlMedium: T = 1
With Range("B32:J32")
    .Merge: .Font.Color = 65535
    .Interior.Pattern = xlSolid: .Interior.Color = 16751052
    .Select: GoSub SSLine
End With
With Range("L32:Q32")
    .Merge: .Font.Color = 65535: .Value = "Bombes à trouver:"
    .Interior.Pattern = xlSolid: .Interior.Color = 8421631
    .HorizontalAlignment = xlRight: .Select: GoSub SSLine
End With
With Range("V32:AA32")
    .Merge: .Font.Color = 65535: .Value = "Cases couvertes:"
    .Interior.Pattern = xlSolid: .Interior.Color = 8421631
    .HorizontalAlignment = xlRight: .Select: GoSub SSLine
End With
T = 0
With Range("R32:T32")
    .Merge: .Font.Color = 32768
    .Interior.Pattern = xlSolid: .Interior.Color = 16763904
    .Select: GoSub SSLine
End With
With Range("AB32:AD32")
    .Merge: .Font.Color = 32768
    .Interior.Pattern = xlSolid: .Interior.Color = 16763904
    .Select: GoSub SSLine
End With
LS = xlDouble: WE = xlThick: T = 1
With Range("AF32:AM32")
    .Merge: .Font.Color = 128: .Font.Bold = True: .Value = "Recommencer (Dbl-Click)"
    .Interior.Pattern = xlSolid: .Interior.Color = 8421631
    .Select: GoSub SSLine
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("A1").Select
Exit Sub
SSLine:
    With Selection
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
    With Selection.Borders(xlEdgeLeft)
If T Then .LineStyle = LS: .Color = -10092442: .Weight = WE Else .LineStyle = xlNone
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = LS: .Color = -10092442: .Weight = WE
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = LS: .Color = -10092442: .Weight = WE
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = LS: .Color = -10092442: .Weight = WE
        'If T Then .LineStyle = xlNone Else .LineStyle = LS: .Color = -10092442: .Weight = WE
    End With
Return
End Sub

-MyLzz59-