Boules_source

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

' -----------------
' Zone Déclarations
' -----------------
Const Tit = "Boules (P)03/2010 MyLzz59"
Const Ym = 30, Xm = 40, Nm = 900, Xt = 2, Xb = 18, Xc = 27, Xr = 32

' -------------------------------------
' EVT: Supprime la Forme Double-Cliquée
' -------------------------------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
: Forme: Cancel = True
End Sub

' -------------------------
' Crée un Nouvel Empilement
' -------------------------
Sub Remplis()
Dim P(1 To Xm) As Integer
Randomize Timer
Sheets(1).Unprotect ""
Range(Cells(1, 1), Cells(Ym, Xm)).Interior.ColorIndex = 15
Range(Cells(1, 1), Cells(Ym, Xm)).ClearContents
For T = 1 To Nm
    Do: X = Int(Rnd * Xm) + 1: Loop While P(X) = Ym
    Cells(Ym - P(X), X).Interior.ColorIndex = Int(Rnd * 4) + 3
    P(X) = P(X) + 1
Next T
Cells(Ym + 2, Xt).Value = Tit
Cells(Ym + 2, Xb).Value = Nm: Cells(Ym + 2, Xc).Value = 0
Sheets(1).Protect ""
End Sub

' ------------------------
' Traite la Forme Désignée
' ------------------------
Sub Forme()
Dim N As Integer
Sheets(1).Unprotect ""
N = 0: Tagge ActiveCell.Row, ActiveCell.Column, N: DoEvents
If N >= 3 Then
    Cells(Ym + 2, Xb).Value = Cells(Ym + 2, Xb).Value - N
    Cells(Ym + 2, Xc).Value = Cells(Ym + 2, Xc).Value + 1: Supprime
Else
    If N > -1 Then Range(Cells(1, 1), Cells(Ym, Xm)).ClearContents
End If
Range("A1").Select: DoEvents
Sheets(1).Protect ""
End Sub

' -------------------
' (utilisé par Forme)
' -------------------
Sub Tagge(ByVal Y As Integer, ByVal X As Integer, ByRef N As Integer)
If X < 1 Or X > Xm Or Y < 1 Or (Y > Ym And Y <> Ym + 2) Then Exit Sub
If Y = Ym + 2 Then
    ' Menu
    N = -1: If X = Xr Then If MsgBox("Réinitialiser l'Aire de Jeu ?", _
        vbQuestion + vbYesNo + vbDefaultButton2, Tit) = vbYes Then Remplis
Else
    ' Zone de Jeu
    Static C
    With Cells(Y, X)
        If N = 0 Then C = .Interior.ColorIndex: If C > 8 Then Exit Sub
        If .Text = "" And .Interior.ColorIndex = C Then
            .Value = "*": N = N + 1
            For T2 = Y - 1 To Y + 1 Step 2: Tagge T2, X, N: Next T2
            For T1 = X - 1 To X + 1 Step 2: Tagge Y, T1, N: Next T1
        End If
    End With
End If
End Sub

' ------------------------
' Supprime la Forme Taggée
' ------------------------
Sub Supprime()
For X = 1 To Xm
        ' Colonne
    For Y = Ym To 1 Step -1
        If Cells(Y, X).Text <> "" Then
            If Y > 1 Then
                Range(Cells(1, X), Cells(Y - 1, X)).Copy
                Range(Cells(2, X), Cells(Y, X)).PasteSpecial xlPasteAll
            End If
            Cells(1, X).Interior.ColorIndex = 15
            Cells(1, X).Value = "": Y = Y + 1
        End If
    Next Y
    ' Ligne
    If X < Xm And Cells(Ym, X).Interior.ColorIndex = 15 Then
        Range(Cells(1, X + 1), Cells(Ym, Xm)).Copy
        Range(Cells(1, X), Cells(Ym, Xm - 1)).PasteSpecial xlPasteAll
        Range(Cells(1, Xm), Cells(Ym, Xm)).Interior.ColorIndex = 15
        Range(Cells(1, Xm), Cells(Ym, Xm)).ClearContents
        If Cells(Ym, X).Interior.ColorIndex <> 15 Then X = X - 1
    End If
Next X
End Sub

-MyLzz59-