Tetris en Excel

Y la parte visual y rangos?

Rangos llamados Block1 to Block7
TextBox1
SHapes NextBlock

no hay algún link donde bajarlo?

muchas gracias!






"Guli" wrote:

José
Crea un modulo y pega el siguiente código

Option Explicit
Dim currentblockformat
Dim NextBlock As Integer
Dim CurrentBlock As Integer
Dim BlockPosition As Range
Dim Pause As Boolean
Dim Rot As Integer
Dim Adj As Double
Dim counter As Integer
Dim NextTime
Sub Auto_Open()
Application.ScreenUpdating = False
Application.GoTo Reference:="View"
ActiveWindow.Zoom = True
ActiveSheet.OLEObjects("TextBox1").Activate
SendKeys "^{Home}", True
Range("score").Select
Clear
End Sub
Sub Auto_Close()
On Error Resume Next
Application.OnTime earliesttime:=NextTime, procedure:="Down1",
schedule:=False
ResetKeys
End Sub
Sub Fit()
Application.ScreenUpdating = False
Application.GoTo Reference:="View"
ActiveWindow.Zoom = True
Range("score").Select
End Sub
Sub SetKeys()
Application.OnKey "{Right}", "Right"
Application.OnKey "{Left}", "Left"
Application.OnKey "{Down}", "Down"
Application.OnKey "{Up}", "Rotate"
End Sub
Sub ResetKeys()
Application.OnKey "{Right}"
Application.OnKey "{Left}"
Application.OnKey "{Down}"
Application.OnKey "{Up}"
End Sub
Sub Tetris()
On Error Resume Next
Adj = 1
ActiveSheet.Protect
If Pause = True Then PauseResume: Exit Sub
Range("score").Select
StopGame
Clear
SetKeys
ActiveSheet.Shapes("GameOverLabel").Visible = False
ChooseNextBlock
NewBlock
Down1
End Sub
Sub ChooseNextBlock()
Dim i As Integer
ActiveSheet.Unprotect
Randomize
NextBlock = Int((7 * Rnd) + 1)
For i = 1 To 7
ActiveSheet.Shapes("NextBlock" & i).Visible = False
Next i
ActiveSheet.Shapes("NextBlock" & NextBlock).Visible = True
ActiveSheet.Protect
End Sub
Sub NewBlock()
ActiveSheet.Unprotect
Rot = 1
CurrentBlock = NextBlock
Select Case CurrentBlock
Case 1
ActiveSheet.Range("Block1").Copy Destination:=Range("h2")
ActiveWorkbook.Names.Add name:="Block", RefersToR1C1:=Range("h2:h5")
ActiveWorkbook.Names.Add name:="a", RefersToR1C1:=Range("h2")
ActiveWorkbook.Names.Add name:="b", RefersToR1C1:=Range("h3")
ActiveWorkbook.Names.Add name:="d", RefersToR1C1:=Range("h4")
ActiveWorkbook.Names.Add name:="e", RefersToR1C1:=Range("h5")
currentblockformat = 1
Case 2
ActiveSheet.Range("Block2").Copy Destination:=Range("h2")
ActiveWorkbook.Names.Add name:="Block", RefersToR1C1:=Range("h2:j3")
ActiveWorkbook.Names.Add name:="a", RefersToR1C1:=Range("i2")
ActiveWorkbook.Names.Add name:="b", RefersToR1C1:=Range("j2")
ActiveWorkbook.Names.Add name:="d", RefersToR1C1:=Range("h3")
ActiveWorkbook.Names.Add name:="e", RefersToR1C1:=Range("i3")
currentblockformat = 2
Case 3
ActiveSheet.Range("Block3").Copy Destination:=Range("h2")
ActiveWorkbook.Names.Add name:="Block", RefersToR1C1:=Range("h2:j3")
ActiveWorkbook.Names.Add name:="a", RefersToR1C1:=Range("h2")
ActiveWorkbook.Names.Add name:="b", RefersToR1C1:=Range("i2")
ActiveWorkbook.Names.Add name:="d", RefersToR1C1:=Range("i3")
ActiveWorkbook.Names.Add name:="e", RefersToR1C1:=Range("j3")
currentblockformat = 3
Case 4
ActiveSheet.Range("Block4").Copy Destination:=Range("h2")
ActiveWorkbook.Names.Add name:="Block", RefersToR1C1:=Range("h2:i4")
ActiveWorkbook.Names.Add name:="a", RefersToR1C1:=Range("h2")
ActiveWorkbook.Names.Add name:="b", RefersToR1C1:=Range("h3")
ActiveWorkbook.Names.Add name:="d", RefersToR1C1:=Range("h4")
ActiveWorkbook.Names.Add name:="e", RefersToR1C1:=Range("i4")
currentblockformat = 4
Case 5
ActiveSheet.Range("Block5").Copy Destination:=Range("h2")
ActiveWorkbook.Names.Add name:="Block", RefersToR1C1:=Range("h2:i4")
ActiveWorkbook.Names.Add name:="a", RefersToR1C1:=Range("i2")
ActiveWorkbook.Names.Add name:="b", RefersToR1C1:=Range("i3")
ActiveWorkbook.Names.Add name:="d", RefersToR1C1:=Range("i4")
ActiveWorkbook.Names.Add name:="e", RefersToR1C1:=Range("h4")
currentblockformat = 5
Case 6
ActiveSheet.Range("Block6").Copy Destination:=Range("h2")
ActiveWorkbook.Names.Add name:="Block", RefersToR1C1:=Range("h2:j3")
ActiveWorkbook.Names.Add name:="a", RefersToR1C1:=Range("h2")
ActiveWorkbook.Names.Add name:="b", RefersToR1C1:=Range("i2")
ActiveWorkbook.Names.Add name:="d", RefersToR1C1:=Range("j2")
ActiveWorkbook.Names.Add name:="e", RefersToR1C1:=Range("i3")
currentblockformat = 6
Case 7
ActiveSheet.Range("Block7").Copy Destination:=Range("h2")
ActiveWorkbook.Names.Add name:="Block", RefersToR1C1:=Range("h2:i3")
ActiveWorkbook.Names.Add name:="a", RefersToR1C1:=Range("h2")
ActiveWorkbook.Names.Add name:="b", RefersToR1C1:=Range("i2")
ActiveWorkbook.Names.Add name:="d", RefersToR1C1:=Range("h3")
ActiveWorkbook.Names.Add name:="e", RefersToR1C1:=Range("i3")
currentblockformat = 7
End Select
ActiveSheet.Protect
ChooseNextBlock
End Sub

Sub Down()
Dim c As Range

On Error GoTo 10:
Range("block").Cut Destination:=Range("block").Offset(1, 0)
Exit Sub
10: For Each c In Range("block").Cells
If c.Interior.ColorIndex <> -4142 And c.Offset(1, 0).Locked = True
And c.Locked = False Then GoTo 20:
Next c
Union(Range("a"), Range("b"), Range("d"), Range("e")).ClearFormats
Range("Block" & currentblockformat & "format").Copy _
Destination:=Union(Range("a").Offset(1, 0), Range("b").Offset(1, 0),
Range("d").Offset(1, 0), Range("e").Offset(1, 0))
Range("a").Offset(1, 0).name = "a"
Range("b").Offset(1, 0).name = "b"
Range("d").Offset(1, 0).name = "d"
Range("e").Offset(1, 0).name = "e"
Range("block").Offset(1, 0).name = "block"
Exit Sub
20: ActiveSheet.Unprotect
Union(Range("a"), Range("b"), Range("d"), Range("e")).Locked = True
ActiveSheet.Protect
UpdateScore (1)
VerifFullLine
GameOver
AddBlock
NewBlock
End Sub

Sub Right()
Dim c As Range

On Error GoTo 10:
Range("block").Cut Destination:=Range("block").Offset(0, 1)
Exit Sub
10: For Each c In Range("block").Cells
If c.Interior.ColorIndex <> -4142 And c.Offset(0, 1).Locked = True
Then Exit Sub
Next c
Union(Range("a"), Range("b"), Range("d"), Range("e")).ClearFormats
Range("Block" & currentblockformat & "format").Copy _
Destination:=Union(Range("a").Offset(0, 1), Range("b").Offset(0, 1),
Range("d").Offset(0, 1), Range("e").Offset(0, 1))
Range("a").Offset(0, 1).name = "a"
Range("b").Offset(0, 1).name = "b"
Range("d").Offset(0, 1).name = "d"
Range("e").Offset(0, 1).name = "e"
Range("block").Offset(0, 1).name = "block"
End Sub

Sub Left()
Dim c As Range

On Error GoTo 10:
Range("block").Cut Destination:=Range("block").Offset(0, -1)
Exit Sub
10: For Each c In Range("block").Cells
If c.Interior.ColorIndex <> -4142 And c.Offset(0, -1).Locked = True
Then Exit Sub
Next c
Union(Range("a"), Range("b"), Range("d"), Range("e")).ClearFormats
Range("Block" & currentblockformat & "format").Copy _
Destination:=Union(Range("a").Offset(0, -1), Range("b").Offset(0, -1),
Range("d").Offset(0, -1), Range("e").Offset(0, -1))
Range("a").Offset(0, -1).name = "a"
Range("b").Offset(0, -1).name = "b"
Range("d").Offset(0, -1).name = "d"
Range("e").Offset(0, -1).name = "e"
Range("block").Offset(0, -1).name = "block"
End Sub

Sub Rotate()
On Error GoTo 10:
Select Case CurrentBlock
Case 1
Select Case Rot
Case 1
If IsNull(Union(Range("a").Offset(1, -1), Range("b").Offset(0,
0), Range("d").Offset(-1, 1), Range("e").Offset(-2, 2)).Locked) Then Exit Sub
Union(Range("a"), Range("b"), Range("d"), Range("e")).ClearFormats
Range("Block" & currentblockformat & "format").Copy _
Destination:=Union(Range("a").Offset(1, -1),
Range("b").Offset(0, 0), Range("d").Offset(-1, 1), Range("e").Offset(-2, 2))
Range("a").Offset(1, -1).name = "a"
Range("b").Offset(0, 0).name = "b"
Range("d").Offset(-1, 1).name = "d"
Range("e").Offset(-2, 2).name = "e"
Union(Range("a"), Range("b"), Range("d"), Range("e")).name =
"block"
Rot = 2
Case 2
If IsNull(Union(Range("a").Offset(-1, 1), Range("b").Offset(0,
0), Range("d").Offset(1, -1), Range("e").Offset(2, -2)).Locked) Then Exit Sub
Union(Range("a"), Range("b"), Range("d"), Range("e")).ClearFormats
Range("Block" & currentblockformat & "format").Copy _
Destination:=Union(Range("a").Offset(-1, 1),
Range("b").Offset(0, 0), Range("d").Offset(1, -1), Range("e").Offset(2, -2))
Range("a").Offset(-1, 1).name = "a"
Range("b").Offset(0, 0).name = "b"
Range("d").Offset(1, -1).name = "d"
Range("e").Offset(2, -2).name = "e"
Union(Range("a"), Range("b"), Range("d"), Range("e")).name =
"block"
Rot = 1
End Select
Case 2
Select Case Rot
Case 1
If IsNull(Union(Range("a").Offset(1, 1), Range("b").Offset(2,
0), Range("d").Offset(-1, 1), Range("e").Offset(0, 0)).Locked) Then Exit Sub
Union(Range("a"), Range("b"), Range("d"), Range("e")).ClearFormats
Range("Block" & currentblockformat & "format").Copy _
Destination:=Union(Range("a").Offset(1, 1), Range("b").Offset(2,
0), Range("d").Offset(-1, 1), Range("e").Offset(0, 0))
Range("a").Offset(1, 1).name = "a"
Range("b").Offset(2, 0).name = "b"
Range("d").Offset(-1, 1).name = "d"
Range("e").Offset(0, 0).name = "e"
Range("Block").Offset(0, 1).Resize(3, 2).name = "block"
Rot = 2
Case 2
If IsNull(Union(Range("a").Offset(-1, -1), Range("b").Offset(-2,
0), Range("d").Offset(1, -1), Range("e").Offset(0, 0)).Locked) Then Exit Sub
Union(Range("a"), Range("b"), Range("d"), Range("e")).ClearFormats
Range("Block" & currentblockformat & "format").Copy _
Destination:=Union(Range("a").Offset(-1, -1),
Range("b").Offset(-2, 0), Range("d").Offset(1, -1), Range("e").Offset(0, 0))
Range("a").Offset(-1, -1).name = "a"
Range("b").Offset(-2, 0).name = "b"
Range("d").Offset(1, -1).name = "d"
Range("e").Offset(0, 0).name = "e"
Range("Block").Offset(0, -1).Resize(2, 3).name = "block"
Rot = 1
End Select
Case 3
Select Case Rot
Case 1
If IsNull(Union(Range("a").Offset(0, 2), Range("b").Offset(1,
1), Range("d").Offset(0, 0), Range("e").Offset(1, -1)).Locked) Then Exit Sub
Union(Range("a"), Range("b"), Range("d"), Range("e")).ClearFormats
Range("Block" & currentblockformat & "format").Copy _
Destination:=Union(Range("a").Offset(0, 2), Range("b").Offset(1,
1), Range("d").Offset(0, 0), Range("e").Offset(1, -1))
Range("a").Offset(0, 2).name = "a"
Range("b").Offset(1, 1).name = "b"
Range("d").Offset(0, 0).name = "d"
Range("e").Offset(1, -1).name = "e"
Range("Block").Offset(0, 1).Resize(3, 2).name = "Block"
Rot = 2
Case 2
If IsNull(Union(Range("a").Offset(0, -2), Range("b").Offset(-1,
-1), Range("d").Offset(0, 0), Range("e").Offset(-1, 1)).Locked) Then Exit Sub
Union(Range("a"), Range("b"), Range("d"), Range("e")).ClearFormats
Range("Block" & currentblockformat & "format").Copy _
Destination:=Union(Range("a").Offset(0, -2),
Range("b").Offset(-1, -1), Range("d").Offset(0, 0), Range("e").Offset(-1, 1))
Range("a").Offset(0, -2).name = "a"
Range("b").Offset(-1, -1).name = "b"
Range("d").Offset(0, 0).name = "d"
Range("e").Offset(-1, 1).name = "e"
Range("Block").Offset(0, -1).Resize(2, 3).name = "Block"
Rot = 1