... Tu me manques :'(
.. @gmail.com
Voici l'Intégralité du Code de "Tris", objet par objet. Si nécessaire (problème de renvois à la ligne dans VBA), passer par un collage dans WordPad..
* ThisWorkBook *
==> rien <==* Tris (Feuille "Tris") *
' -----------------
' Annuler l'Edition
' -----------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True: If Target.Address = XYTi Then UF1.Show 0: MyTimer
End Sub
' --------------------------
' Annuler le Menu Contextuel
' --------------------------
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
End Sub
' --------------------------
' Sorte de Timer (1 seconde)
' --------------------------
Private Sub MyTimer()
K& = Timer
Do
DoEvents: K2& = Timer
If K2& <> K& Then K& = K2&: If Dsc = True And Sta = 1 Then UF1.UFKD -1
Loop
End Sub* "UF1" (UserForm) *
' ----------------
' Démarrage Pilote
' ----------------
Private Sub UserForm_Initialize()
With Tris
Sui = .Range(XYaS).Text <> "": .Range(XYaS).Value = IIf(Sui, "X", "")
Dsc = .Range(XYaD).Text <> "": .Range(XYaD).Value = IIf(Dsc, "X", "")
End With
Randomize Timer: Sta = 0: UFCL: GenerePiece: UFKD 101
End Sub
' ------------
' EVTs Touches
' ------------
' Touches du Jeu
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
UFKD KeyCode ' A cause du MSForms.ReturnInteger
End Sub
' Touche "Echap"
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 27 Then UserForm_QueryClose 0, 1
End Sub
' ----------------
' Fermeture Pilote
' ----------------
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = True
Select Case MsgBox("** Menu Principal **" + vbCr + vbCr _
+ "[Oui] Démarrer une Nouvelle Partie" + vbCr _
+ "[Non] Fermer la Fenêtre Pilote" + vbCr + "[Ann] Retour au Jeu" _
, vbDefaultButton3 + vbYesNoCancel + vbInformation, Tris.Range("M20").Text)
Case vbYes: UserForm_Initialize
Case vbNo: UFCL: End
End Select
End Sub
' ---------------
' Gestion Touches
' ---------------
Public Sub UFKD(ByVal KeyCode As Integer)
If Sta = 1 Then
' En cours
DessinePiece 1, False
Select Case KeyCode
' Déplacements (Gauche: "4" ou Pavé Gauche, Droite: "6" ou Pavé Droite)
Case 37, 100: Recopie True: X0(2) = X0(2) - 1 ' Gauche
Case 39, 102: Recopie True: X0(2) = X0(2) + 1 ' Droite
' Bas (Auto)
Case -1: Recopie True: Y0(2) = Y0(2) + 1: If TestePiece(2) = False Then Sta = 0
' Rotations (TG:"7", TD:"9" ou Pavé Haut)
Case 38, 103, 105: TGTD KeyCode <> 103
' Tomber (Pavé Bas ou Entrée)
Case 13, 40: Recopie True
Do: Y0(2) = Y0(2) + 1: Loop While TestePiece(2): Y0(2) = Y0(2) - 1: Sta = 0
End Select
If TestePiece(2) Then Recopie False
DessinePiece 1, True: If Sta = 0 Then TesteLignes: If Sui Then UFKD 101
ElseIf Sta = 0 Then
' Aucune
Select Case KeyCode
' Nouveau ("5" ou Pavé Haut)
Case 38, 101: X0(2) = (CLf + CRt) \ 2: Y0(2) = CUp: GenerePiece
If TestePiece(2) Then
Sta = 1: Tris.Range(XYPc).Value = Tris.Range(XYPc).Value + 1 ' Pièces
Recopie False: DessinePiece 1, True
Else
Sta = 2: Griser: MsgBox "Perdu", vbCritical
End If
End Select
End If
End Sub
' ------------------------
' Nettoyage de l'Interface
' ------------------------
Private Sub UFCL()
Tris.Range(XYLi).Value = 0: Tris.Range(XYPt).Value = 0: Tris.Range(XYPc).Value = 0
With Tris
.Range(.Cells(CUp0, CLf0), .Cells(CUp0 + 1, CLf0 + 3)).Interior.Color = C0
End With
With Tris.Range(Tris.Cells(CUp, CLf), Tris.Cells(CDn, CRt))
.Interior.Color = C0: .Font.Color = C0: .ClearContents
End With
End Sub
* "pTris" (Module) *
' -----------------
' Zone Déclarations
' -----------------
Public Const CUp As Integer = 2, CDn As Integer = 21, CLf As Integer = 2, CRt As Integer = 11
Public Const C0 As Long = &HFFCCCC, CUp0 As Integer = 13, CLf0 As Integer = 13
Public Const XYLi = "M4", XYPt = "M7", XYPc = "M10"
Public Const XYaS = "M17", XYaD = "M18", XYTi = "$M$20:$P$21"
Public X0(1 To 2) As Integer, Y0(1 To 2) As Integer
Public PX(0 To 2, 1 To 4) As Integer, PY(0 To 2, 1 To 4) As Integer
Public PC(0 To 2) As Long, Sta As Integer, Sui As Boolean, Dsc As Boolean
' ----------------------------------------------------------
' Crée une Pièce (en No=0, et Recopie la Précédente en No=2)
' ----------------------------------------------------------
Sub GenerePiece()
' Tirage
Select Case Int(Rnd * 5)
Case 0: Z$ = "-1 0-1 1 0 0 1 0" ' L
Case 1: Z$ = "-1 0 0 0 0 1 1 0" ' T
Case 2: Z$ = " 0 0 0 1 1 0 1 1" ' O
Case 3: Z$ = "-1 0 0 0 1 0 2 0" ' I
Case 4: Z$ = "-1 0 0 0 1 0 1 1" ' J
End Select
' Nettoyage "Suivante"
With Tris
.Range(.Cells(CUp0, CLf0), .Cells(CUp0 + 1, CLf0 + 3)).Interior.Color = C0
End With
' Affectation et Dessin "Suivante
T = 1 + Int(Rnd * 6)
PC(2) = PC(0): PC(0) = -(65536 * ((T And 4) <> 0) _
+ 256& * ((T And 2) <> 0) + 1& * ((T And 1) <> 0)) * 204
For T = 1 To 4
PX(2, T) = PX(0, T): PX(0, T) = Val(Mid$(Z$, 4 * T - 3, 2))
PY(2, T) = PY(0, T): PY(0, T) = Val(Mid$(Z$, 4 * T - 1, 2))
Tris.Cells(CUp0 + PY(0, T), CLf0 + PX(0, T) + 1).Interior.Color = PC(0)
Next T
End Sub
' ----------------------------------------------
' Teste la Pièce (No=1: en cours, No=2: travail)
' ----------------------------------------------
Function TestePiece(No As Integer) As Boolean
If No = 1 Or No = 2 Then
B = True
For T = 1 To 4
X = X0(No) + PX(No, T): Y = Y0(No) + PY(No, T)
If X < CLf Or X > CRt Then
B = False
ElseIf Y < CUp Or Y > CDn Then
B = False
ElseIf Tris.Cells(Y, X).Text <> "" Then
B = False
End If
Next T
Else
B = False
End If
TestePiece = B
End Function
' ------------------------------------------------------
' Dessine (Aff=True) ou Efface (Aff=False) la Pièce (No)
' ------------------------------------------------------
Sub DessinePiece(No As Integer, Aff As Boolean)
For T = 1 To 4
X = X0(No) + PX(No, T): Y = Y0(No) + PY(No, T)
With Tris.Cells(Y, X)
.Interior.Color = IIf(Aff, PC(No), C0)
.Font.Color = IIf(Aff, PC(No), C0)
.Value = IIf(Aff, "*", "")
End With
Next T
End Sub
' -----------------------------------
' Recopie 2=>1 (False) ou 1=>2 (True)
' -----------------------------------
Sub Recopie(D12 As Boolean)
PC(1 - D12) = PC(2 + D12): X0(1 - D12) = X0(2 + D12): Y0(1 - D12) = Y0(2 + D12)
For T = 1 To 4: PX(1 - D12, T) = PX(2 + D12, T): PY(1 - D12, T) = PY(2 + D12, T): Next T
End Sub
' --------------------------------------------
' Rotation 90° Gauche (False) ou Droite (True)
' --------------------------------------------
Sub TGTD(Dr As Boolean)
X1 = 0: Y1 = 0
For T = 1 To 4
PY(2, T) = IIf(Dr, 1, -1) * PX(1, T): PX(2, T) = IIf(Dr, -1, 1) * PY(1, T)
X = X0(1) + PX(2, T): Y = Y0(1) + PY(2, T)
If X < CLf Then If X - CLf < X1 Then X1 = X - CLf
If Y < CUp Then If Y - CUp < Y1 Then Y1 = Y - CUp
If X > CRt Then If X - CRt > X1 Then X1 = X - CRt
If Y > CDn Then If Y - CDn > Y1 Then Y1 = Y - CDn
Next T
X0(2) = X0(1) - X1: Y0(2) = Y0(1) - Y1
End Sub
' ------------
' Teste Lignes
' ------------
Sub TesteLignes()
With Tris
T = 0 ' 1ère Ligne: 10Pts, 2ème Ligne: 15Pts, etc..
For Y1 = CDn To CUp Step -1
' Est-ce une Ligne ?
B = True
For X1 = CLf To CRt
If .Cells(Y1, X1).Text = "" Then B = False
Next X1
' Action
If B Then
.Range(XYLi).Value = .Range(XYLi).Value + 1 ' Lignes
.Range(XYPt).Value = .Range(XYPt).Value + 10 + T: T = T + 5 ' Points
' Décalage du Dessus de la Ligne
If Y1 > CUp Then
.Range(.Cells(CUp, CLf), .Cells(Y1 - 1, CRt)).Copy _
Tris.Range(.Cells(CUp + 1, CLf), .Cells(Y1, CRt))
End If
With .Range(.Cells(CUp, CLf), .Cells(CUp, CRt))
.Interior.Color = C0: .Font.Color = C0: .ClearContents
End With
' Redessiner Bordure Epaisse en Bas
If Y1 = CDn Then _
.Range(.Cells(CDn, CLf), .Cells(CDn, CRt)) _
.Borders(xlEdgeBottom).Weight = xlThick
Y1 = Y1 + 1
End If
Next Y1
B = True ' Bonus: Ecran Vide=1000Pts
For X1 = CLf To CRt
If .Cells(CDn, X1).Text <> "" Then B = False
Next X1
If B Then .Range(XYPt).Value = .Range(XYPt).Value + 1000
End With
End Sub
' --------------
' Griser (Perdu)
' --------------
Sub Griser()
With Tris
For Y1 = CDn To CUp Step -1: For X1 = CLf To CRt
V& = .Cells(Y1, X1).Interior.Color: V2& = 0
For T = 0 To 2: V2& = V2& + V& Mod 256: V& = V& \ 256: Next T
V2& = 65793 * (V2& \ 3): .Cells(Y1, X1).Interior.Color = V2&
.Cells(Y1, X1).Font.Color = V2&
Next X1, Y1
End With
End Sub-MyLzz59-