俄罗斯方块VBA

Attribute VB_Name = "俄罗斯方块"
Option Explicit

'如果对VBA不是很了解,请先关闭所有的Excel 程序,请修改此文件的扩展名为.bas以用于后序的导入(改名后也可用记事本打开)
'1.打开Excel (2007版,其它版没有试验过)->新建工作簿(默认已经创建)->另存为启用宏的Excel工作簿文件
'2.Excel 菜单栏 点 开发工具(如果没有 则进入Excel 选项->常用->钩选 在功能区显示"开发工具"选项卡)->宏安全性->选择启用所有宏->确定
'3.Excel 菜单栏 点 开发工具->Visual Basic->进入VBA工程界面
'4.工程界面左侧找到 ThisWorkbook -> 右键-> 导入文件..->选择此文件(文件名应为XXX.bas,如果文件扩展名不是.bas请先修改之)
'5.正确导入文件后左上侧会多出 模块项 展开 模块 有 俄罗斯方块
'6.双击刚才那个 ThisWorkbook -> 打开一个空白代码窗口
'7.窗口上方有两个下拉框,左面下拉框选择 Workbook -> 右边会自动变成 Open 下方会多出代码 在private...与End...之间空行输入 init ->回车后会变成 Init
'8.再在右面下拉框选择 BeforeClose ->下面会又多出两行代码 同上在代码之间空行输入 timeend 回车后变成 TimeEnd,最终代码如下
'
' Private Sub Workbook_BeforeClose(Cancel As Boolean)
' TimeEnd
'
' End Sub
'
' Private Sub Workbook_Open()
' Init
'
' End Sub
'
'9.保存->关闭Excel 然后重新打开刚才那个启用宏的Excel文件

'注:对于了解VBA的可以直接用下面的代码,代码怎么用你懂的!!!!

' 作者:hpfrog@https://www.sodocs.net/doc/1614145946.html,

Public Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Public Const DIS_X_COL As Long = 4
Public Const DIS_Y_ROW As Long = 3
Public Const DIS_W_COLS As Long = 13
Public Const DIS_H_ROWS As Long = 19
Public Const MD_COLOR As Variant = 65280
Public Const BK_COLOR As Variant = 16764006
Public TimeCnt As Long
Public TrgTime As Long
Public Tid As Long
Public CurT As Long
Public Bk(0 To 27, 0 To 13) As Variant
Public State As Integer
Public CurBounds As Long
Public CurData(0 To 3, 0 To 3) As Variant
Public CurRow As Long
Public CurCol As Long
Public CurRnd As Long
Public CurMd As Long
Public NextMd As Long
Public NextRnd As Long
Public isBusy As Boolean

'形状,方向,row,col
Public Md(0 To 6, 0 To 3, 0 To 3, 0 To 3) As Variant

Public Sub MkMd()
Dim M, N, R, C
For M = 0 To 6
For N = 0 To 3
For R = 0 To 3
For C = 0 To 3
Md(M, N, R, C) = BK_COLOR
Next
Next

Next
Next
Md(0, 0, 0, 0) = MD_COLOR
Md(0, 0, 0, 1) = MD_COLOR
Md(0, 0, 0, 2) = MD_COLOR
Md(0, 0, 0, 3) = MD_COLOR

Md(0, 1, 0, 0) = MD_COLOR
Md(0, 1, 1, 0) = MD_COLOR
Md(0, 1, 2, 0) = MD_COLOR
Md(0, 1, 3, 0) = MD_COLOR

Md(0, 2, 0, 0) = MD_COLOR
Md(0, 2, 0, 1) = MD_COLOR
Md(0, 2, 0, 2) = MD_COLOR
Md(0, 2, 0, 3) = MD_COLOR

Md(0, 3, 0, 0) = MD_COLOR
Md(0, 3, 1, 0) = MD_COLOR
Md(0, 3, 2, 0) = MD_COLOR
Md(0, 3, 3, 0) = MD_COLOR

Md(1, 0, 0, 0) = MD_COLOR
Md(1, 0, 0, 1) = MD_COLOR
Md(1, 0, 1, 0) = MD_COLOR
Md(1, 0, 1, 1) = MD_COLOR

Md(1, 1, 0, 0) = MD_COLOR
Md(1, 1, 0, 1) = MD_COLOR
Md(1, 1, 1, 0) = MD_COLOR
Md(1, 1, 1, 1) = MD_COLOR

Md(1, 2, 0, 0) = MD_COLOR
Md(1, 2, 0, 1) = MD_COLOR
Md(1, 2, 1, 0) = MD_COLOR
Md(1, 2, 1, 1) = MD_COLOR

Md(1, 3, 0, 0) = MD_COLOR
Md(1, 3, 0, 1) = MD_COLOR
Md(1, 3, 1, 0) = MD_COLOR
Md(1, 3, 1, 1) = MD_COLOR

Md(2, 0, 0, 0) = MD_COLOR
Md(2, 0, 1, 0) = MD_COLOR
Md(2, 0, 1, 1) = MD_COLOR
Md(2, 0, 2, 1) = MD_COLOR

Md(2, 1, 0, 1) = MD_COLOR
Md(2, 1, 0, 2) = MD_COLOR
Md(2, 1, 1, 0) = MD_COLOR
Md(2, 1, 1, 1) = MD_COLOR

Md(2, 2, 0, 0) = MD_COLOR
Md(2, 2, 1, 0) = MD_COLOR
Md(2, 2, 1, 1) = MD_COLOR
Md(2, 2, 2, 1) = MD_COLOR

Md(2, 3, 0, 1) = MD_COLOR
Md(2, 3, 0, 2) = MD_COLOR
Md(2, 3, 1, 0) = MD_COLOR
Md(2, 3, 1, 1) = MD_COLOR

Md(3, 0, 0, 1) = MD_COLOR
Md(3, 0, 1, 0) = MD_COLOR
Md(3, 0, 1, 1) = MD_COLOR
Md(3, 0, 2, 0) = MD_COLOR

Md(3, 1, 0, 0) = MD_COLOR
Md(3, 1, 0, 1) = MD_COLOR
Md(3, 1, 1, 1) = MD_COLOR
Md(3, 1, 1, 2) = MD_COLOR

Md(3, 2, 0, 1) = MD_COLOR
Md(3, 2, 1, 0) = MD_COLOR
Md(3, 2, 1, 1) = MD_COLOR
Md(3, 2, 2, 0) = MD_COLOR

Md(3, 3, 0, 0) = MD_COLOR
Md(3, 3, 0, 1) = MD_COLOR
Md(3, 3, 1, 1) = MD_COLOR
Md(3, 3, 1, 2) = MD_COLOR

Md(4, 0, 0, 0) = MD_COLOR
Md(4, 0, 1, 0) = MD_COLOR
Md(4, 0, 1, 1) = MD_COLOR
Md(4, 0, 2, 0) = MD_COLOR

Md(4, 1, 0, 0) = MD_COLOR
Md(4, 1, 0, 1) = MD_COLOR
Md(4, 1, 0, 2) = MD_COLOR
Md(4, 1, 1, 1) = MD_COLOR

Md(4, 2, 0, 1) = MD_COLOR
Md(4, 2, 1, 0) = MD_COLOR
Md(4, 2, 1, 1) = MD_COLOR
Md(4, 2, 2, 1) = MD_COLOR

Md(4, 3, 0, 1) = MD_COLOR
Md(4, 3, 1, 0) = MD_COLOR
Md(4, 3, 1, 1) = MD_COLOR
Md(4, 3, 1, 2) = MD_COLOR

Md(5, 0, 0, 0) = MD_COLOR
Md(5, 0, 0, 1) = MD_COLOR
Md(5, 0, 0, 2) = MD_COLOR
Md(5, 0, 1, 0) = MD_COLOR

Md(5, 1, 0, 0) = MD_COLOR
Md(5, 1, 0, 1) = MD_COLOR
Md(5, 1, 1, 1) = MD_COLOR
Md(5, 1, 2, 1) = MD_COLOR

Md(5, 2, 0, 2) = MD_COLOR
Md(5, 2, 1, 0) = MD_COLOR
Md(5, 2, 1, 1) = MD_COLOR
Md(5, 2, 1, 2) = MD_

COLOR

Md(5, 3, 0, 0) = MD_COLOR
Md(5, 3, 1, 0) = MD_COLOR
Md(5, 3, 2, 0) = MD_COLOR
Md(5, 3, 2, 1) = MD_COLOR

Md(6, 0, 0, 0) = MD_COLOR
Md(6, 0, 1, 0) = MD_COLOR
Md(6, 0, 1, 1) = MD_COLOR
Md(6, 0, 1, 2) = MD_COLOR

Md(6, 1, 0, 0) = MD_COLOR
Md(6, 1, 0, 1) = MD_COLOR
Md(6, 1, 1, 0) = MD_COLOR
Md(6, 1, 2, 0) = MD_COLOR

Md(6, 2, 0, 0) = MD_COLOR
Md(6, 2, 0, 1) = MD_COLOR
Md(6, 2, 0, 2) = MD_COLOR
Md(6, 2, 1, 2) = MD_COLOR

Md(6, 3, 0, 1) = MD_COLOR
Md(6, 3, 1, 1) = MD_COLOR
Md(6, 3, 2, 0) = MD_COLOR
Md(6, 3, 2, 1) = MD_COLOR

For R = 0 To DIS_H_ROWS
For C = 0 To DIS_W_COLS
Bk(R, C) = BK_COLOR
Next
Next
End Sub


Public Sub Init()
Application.OnKey "{LEFT}", "OnKeyLeft"
Application.OnKey "{RIGHT}", "OnKeyRight"
Application.OnKey "{UP}", "OnKeyUp"
Application.OnKey "{DOWN}", "OnKeyDown"

Sheet1.Activate
With Sheet1.Range("C2:Y24").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Sheet1.Range("C2:R2").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16711680
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Sheet1.Range("C2:C23").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16711680
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Sheet1.Range("R2:R23").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16711680
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Sheet1.Range("C23:R23").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 16711680
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Sheet1.Range("C1:Y24").ColumnWidth = Sheet1.Cells(1, 1).ColumnWidth / Sheet1.Cells(1, 1).Width * 9
Sheet1.Range("C1:Y24").RowHeight = Sheet1.Cells(1, 1).RowHeight / Sheet1.Cells(1, 1).Height * 12
Sheet1.Rows(2).RowHeight = Sheet1.Cells(1, 1).RowHeight / Sheet1.Cells(1, 1).Height * 5
Sheet1.Rows(23).RowHeight = Sheet1.Cells(1, 1).RowHeight / Sheet1.Cells(1, 1).Height * 5
Sheet1.Columns(3).ColumnWidth = Sheet1.Cells(1, 1).ColumnWidth / Sheet1.Cells(1, 1).Width * 3
Sheet1.Columns(18).ColumnWidth = Sheet1.Cells(1, 1).ColumnWidth / Sheet1.Cells(1, 1).Width * 3
With Sheet1.Range("T10")
.NumberFormatLocal = "@"
.FormulaR1C1 = "L:0"
End With
With Sheet1.Range("T12")
.NumberFormatLocal = "@"
.FormulaR1C1 = "F:0"
End With
Sheet1.Range("T14") = "T:0.0.0.0"
State = 0
Sheet1.Range("Z5") = "↑:开始/

旋转"
Sheet1.Range("Z7") = "↓:下降"
Sheet1.Range("Z9") = "←:左移"
Sheet1.Range("Z11") = "→:右移"
Sheet1.Range("E26") = "启用宏方可运行"
Sheet1.Cells(1, 1).Select
End Sub
Public Sub OnKeyLeft()
If State > 0 And isBusy = False Then
isBusy = True
LeftMove Sheet1
isBusy = False
End If
End Sub
Public Sub OnKeyRight()
If State > 0 And isBusy = False Then
isBusy = True
RightMove Sheet1
isBusy = False
End If
End Sub
Public Sub OnKeyUp()
Dim R, C
If State = 0 Then
MkMd
Randomize
NextMd = CInt(Rnd() * 6)
NextRnd = CInt(Rnd() * 3)
CurRow = -4
CurCol = DIS_W_COLS \ 2 - 1
CurRnd = NextRnd
CurMd = NextMd
State = 1
TrgTime = 11 - (State Mod 11)
NextMd = CInt(Rnd() * 6)
NextRnd = CInt(Rnd() * 3)
For R = 0 To 3
For C = 0 To 3
Sheet1.Cells(DIS_Y_ROW + 1 + R, DIS_X_COL + DIS_W_COLS + 3 + C).Interior.Color = Md(NextMd, NextRnd, R, C)
Next
Next
Displaybk DIS_Y_ROW, DIS_X_COL
isBusy = False
CurBounds = 0
With Sheet1.Range("T10")
.NumberFormatLocal = "@"
.FormulaR1C1 = "L:1"
End With
With Sheet1.Range("T12")
.NumberFormatLocal = "@"
.FormulaR1C1 = "F:0"
End With
TimeStart
ElseIf isBusy = False Then
isBusy = True
UpRnd Sheet1
isBusy = False
End If

End Sub
Public Sub OnKeyDown()
If State > 0 And isBusy = False Then
isBusy = True
DownMove Sheet1
isBusy = False
End If
End Sub
Public Sub Displaybk(TheRow As Long, TheCol As Long)
Dim i As Long, j As Long, k As Long
With Sheet1
For i = TheRow To TheRow + DIS_H_ROWS
k = i - TheRow
For j = TheCol To TheCol + DIS_W_COLS
.Cells(i, j).Interior.Color = Bk(k, j - TheCol)
Next
Next
End With
End Sub

Sub TimeStart()
CurT = 0
Sheet1.Range("T14") = "T:0-0-0.0"
Tid = SetTimer(Application.hwnd, 10, 100, AddressOf TimeDo)
End Sub
Sub TimeEnd()
KillTimer Application.hwnd, Tid
End Sub

Sub TimeDo()
CurT = CurT + 1
Sheet1.Range("T14") = "T:" & (CurT \ 36000) & "." & ((CurT Mod 36000) \ 600) & "." & ((CurT Mod 600) \ 10) & "." & (CurT Mod 10)
TimeCnt = TimeCnt + 1
If TimeCnt > TrgTime And isBusy = False Then
isBusy = True
TimeCnt = 0
DownMove Sheet1
isBusy = False
End If
End Sub



Public Sub UpRnd(TarSheet As Worksheet)
Dim Tar
If CurRnd = 3 Then Tar = 0 Else Tar = CurRnd + 1
Dim R, C, M
For R = 0 To 3
For C = 0 To 3
M = Md(CurMd, Tar, R, C)
If M = MD_COLOR And M <> Md(CurMd, CurRnd, R, C) Then

If (CurRow + R) > DIS_H_ROWS Or (CurCol + C) > DIS_W_COLS Then
Exit Sub
ElseIf CurRow + R > -1 Then
If M = Bk(CurRow + R, CurCol + C) Then Exit Sub
End If
End If
Next
Next
For R = 0 To 3
If CurRow + R > -1 Then
For C = 0 To 3
M = Md(CurMd, Tar, R, C)
If M <> Md(CurMd, CurRnd, R, C) Then
Bk(CurRow + R, CurCol + C) = M
TarSheet.Cells(DIS_Y_ROW + CurRow + R, DIS_X_COL + CurCol + C).Interior.Color = M
End If
Next
End If
Next
CurRnd = Tar
DoEvents
End Sub

Public Sub LeftMove(TarSheet As Worksheet)
Dim Tar
If CurCol < 1 Then Exit Sub
Tar = CurCol - 1
Dim R, C
For R = 0 To 3
If CurRow + R > -1 Then
For C = 0 To 3
If Md(CurMd, CurRnd, R, C) <> MD_COLOR Then
If C < 3 Then
If Md(CurMd, CurRnd, R, C + 1) = MD_COLOR Then
If Bk(CurRow + R, CurCol + C) = MD_COLOR Then Exit Sub
Exit For
End If
End If
ElseIf C = 0 Then
If Bk(CurRow + R, Tar) = MD_COLOR Then Exit Sub
Exit For
End If
Next
End If
Next
For R = 0 To 3
If CurRow + R > -1 Then
For C = 0 To 3
If Md(CurMd, CurRnd, R, C) = MD_COLOR Then
Bk(CurRow + R, Tar + C) = MD_COLOR
Bk(CurRow + R, CurCol + C) = BK_COLOR
TarSheet.Cells(DIS_Y_ROW + CurRow + R, DIS_X_COL + Tar + C).Interior.Color = MD_COLOR
TarSheet.Cells(DIS_Y_ROW + CurRow + R, DIS_X_COL + CurCol + C).Interior.Color = BK_COLOR
End If
Next
End If
Next
CurCol = Tar
DoEvents
End Sub

Public Sub RightMove(TarSheet As Worksheet)
Dim Tar
If CurCol >= DIS_W_COLS Then Exit Sub
Tar = CurCol + 1
Dim R, C
For R = 0 To 3
If CurRow + R > -1 Then
For C = 0 To 3
If Md(CurMd, CurRnd, R, C) = MD_COLOR Then
If C = 3 Then
If Tar + C > DIS_W_COLS Then
Exit Sub
ElseIf Bk(CurRow + R, Tar + C) = MD_COLOR Then
Exit Sub
End If
Exit For
ElseIf Md(CurMd, CurRnd, R, C + 1) <> MD_COLOR Then
If Tar + C > DIS_W_COLS Then
Exit Sub
ElseIf Bk(CurRow + R, Tar + C) = MD_COLOR Then
Exit Sub
End If
Exit For

End If
End If
Next
End If
Next
For R = 0 To 3
If CurRow + R > -1 Then
For C = 3 To 0 Step -1
If Md(CurMd, CurRnd, R, C) = MD_COLOR Then
Bk(CurRow + R, Tar + C) = MD_COLOR
Bk(CurRow + R, CurCol + C) = BK_COLOR
TarSheet.Cells(DIS_Y_ROW + CurRow + R, DIS_X_COL + Tar + C).Interior.Color = MD_COLOR
TarSheet.Cells(DIS_Y_ROW + CurRow + R, DIS_X_COL + CurCol + C).Interior.Color = BK_COLOR
End If
Next
End If
Next
CurCol = Tar
DoEvents
End Sub

Public Sub DownMove(TarSheet As Worksheet)
Dim Tar
Tar = CurRow + 1
Dim R, C
For C = 0 To 3
For R = 0 To 3
If CurRow + R > -1 Then
If Md(CurMd, CurRnd, R, C) = MD_COLOR Then
If R = 3 Then
If Tar + R > DIS_H_ROWS Or Bk(Tar + R, CurCol + C) = MD_COLOR Then
CheckCur TarSheet
TrgTime = 11 - (State Mod 11)
Exit Sub
End If
Exit For
ElseIf Md(CurMd, CurRnd, R + 1, C) <> MD_COLOR Then
If Tar + R > DIS_H_ROWS Or Bk(Tar + R, CurCol + C) = MD_COLOR Then
CheckCur TarSheet
TrgTime = 11 - (State Mod 11)
Exit Sub
End If
Exit For
End If
End If
End If
Next
Next
For C = 0 To 3
For R = 3 To 0 Step -1
If Md(CurMd, CurRnd, R, C) = MD_COLOR Then
If Tar + R > -1 Then
Bk(Tar + R, CurCol + C) = MD_COLOR
End If
If CurRow + R > -1 Then Bk(CurRow + R, CurCol + C) = BK_COLOR
If Tar + R > -1 Then TarSheet.Cells(DIS_Y_ROW + Tar + R, DIS_X_COL + CurCol + C).Interior.Color = MD_COLOR
If CurRow + R > -1 Then TarSheet.Cells(DIS_Y_ROW + CurRow + R, DIS_X_COL + CurCol + C).Interior.Color = BK_COLOR
End If
Next
Next
CurRow = Tar
DoEvents
End Sub

Public Function CheckCur(TarSheet As Worksheet)
Dim R As Long, C As Long, Rend As Long, R1 As Long, F As Long
F = 0
Rend = CurRow
If Rend < 0 Then Rend = 0
For R = Rend To CurRow + 3
For C = 0 To DIS_W_COLS
If Bk(R, C) <> MD_COLOR Then
C = 0
Exit For
End If
Next
If C > 0 Then
For R1 = R - 1 To 0 Step -1
For C = 0 To DIS_W_COLS
Bk(R1 + 1, C) = Bk(R1, C)
TarSheet.Cells(DIS_Y_ROW + R1 + 1, DIS_X_COL + C).Interior.Color = Bk(R1, C)
Ne

xt
Next
For C = 0 To DIS_W_COLS
Bk(0, C) = BK_COLOR
TarSheet.Cells(DIS_Y_ROW, DIS_X_COL + C).Interior.Color = BK_COLOR
Next
If CurRow < 0 Then
R1 = -CurRow
If R1 < 4 Then
For C = 0 To 3
Bk(0, DIS_X_COL + CurCol + C) = Md(CurMd, CurRnd, R1, C)
TarSheet.Cells(DIS_Y_ROW, DIS_X_COL + CurCol + C).Interior.Color = Md(CurMd, CurRnd, R1, C)
Next
End If
End If
F = F + 1
CurBounds = CurBounds + (F * 100)
State = ((CurBounds / 5000) Mod 10) + 1
Sheet1.Range("T10").FormulaR1C1 = "L:" & State
Sheet1.Range("T12").FormulaR1C1 = "F:" & CurBounds
End If
Next
For C = 0 To DIS_W_COLS
If Bk(0, C) = MD_COLOR Then
C = 0
Exit For
End If
Next
If C < DIS_W_COLS Then
State = 0
TimeEnd
MsgBox "游戏结束!您的得分是" & CurBounds, vbOKOnly, https://www.sodocs.net/doc/1614145946.html,
For R = 0 To DIS_H_ROWS
For C = 0 To DIS_W_COLS
Bk(R, C) = BK_COLOR
Next
Next
Displaybk DIS_Y_ROW, DIS_X_COL
Else
CurRow = -3
CurCol = DIS_W_COLS \ 2 - 1
CurRnd = NextRnd
CurMd = NextMd
Randomize
NextMd = CInt(Rnd() * 6)
NextRnd = CInt(Rnd() * 3)
For R = 0 To 3
For C = 0 To 3
TarSheet.Cells(DIS_Y_ROW + 1 + R, DIS_X_COL + DIS_W_COLS + 3 + C).Interior.Color = Md(NextMd, NextRnd, R, C)
Next
Next
End If
End Function