废话少说。现在我把一年多前的在Excel环境下用vba实现的俄罗斯方块的代码提供给大家，算是对拓展office应用的一个总结。由于程序是在去年写的，现在看来思路都有点不记得了，而且语句都不太高效。但我又懒得修改了，毕竟这个是可以正确运行的。大家参考我另外两篇相关的文章，试着做吧。
还是新建一个宏，键入下面代码。
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long '首先是API函数调用的声明。
Type pos_
row As Long
col As Long
End Type
Type obj
pos As pos_
stat As Long
typ As Long
color As Long
End Type '基本对象数据结构的定义
Public cur_obj As obj
Public prv_obj As obj
Public nex_obj As obj
Public objs_array(27, 3) As pos_
Dim startpos As pos_
Dim nextpos As pos_
Global score As Long '分数
Public score_level As Long
Dim level As Long
Public gaming As Boolean
Public pulse As Boolean
Public interval As Long '定时器时间间隙
Public timerset As Long '定时器
Public top As Long '记录方块堆积的最高层所在行
Public Const mosttop As Long = 5 '游戏区域的顶，当方块堆积到这里游戏结束
Public Const left As Long = 5 '游戏区域左边界
Public Const right As Long = 22 '游戏区域左边界
Public Const middle As Long = (left + right) \ 2 '游戏区域中线，用以定位
Public Const bottom As Long = 25 '游戏区域底
Sub main()
gaming = False
If Worksheets.Count < 2 Then
ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
Else
Worksheets(Worksheets.Count).Select
End If
Load UserForm1
UserForm1.Show
End Sub
Function game_initial()
'游戏初始化函数
startpos.row = mosttop
startpos.col = middle
nextpos.row = mosttop
nextpos.col = right + 8
top = bottom - 1
score = 0
Range(Cells(mosttop + 1, left), Cells(bottom - 1, left)).Interior.ColorIndex = 1
Range(Cells(mosttop + 1, right), Cells(bottom - 1, right)).Interior.ColorIndex = 1
Range(Cells(bottom, left), Cells(bottom, right)).Interior.ColorIndex = 1
Range(Cells(bottom, left), Cells(bottom, right)) = " "
If Not gaming Then
Cells.ColumnWidth = 1
Cells.RowHeight = 10
'初始化各形状的方块，我都忘了哪个对应哪种类型了
objs_array(0, 0).row = -1
objs_array(0, 0).col = -1
objs_array(0, 1).row = 0
objs_array(0, 1).col = -1
objs_array(0, 2).row = 0
objs_array(0, 2).col = 0
objs_array(0, 3).row = 1
objs_array(0, 3).col = 0
objs_array(1, 0).row = 0
objs_array(1, 0).col = 0
objs_array(1, 1).row = 0
objs_array(1, 1).col = 1
objs_array(1, 2).row = 1
objs_array(1, 2).col = 0
objs_array(1, 3).row = 1
objs_array(1, 3).col = -1
objs_array(2, 0).row = -1
objs_array(2, 0).col = -1
objs_array(2, 1).row = 0
objs_array(2, 1).col = -1
objs_array(2, 2).row = 0
objs_array(2, 2).col = 0
objs_array(2, 3).row = 1
objs_array(2, 3).col = 0
objs_array(3, 0).row = 0
objs_array(3, 0).col = 0
objs_array(3, 1).row = 0
objs_array(3, 1).col = 1
objs_array(3, 2).row = 1
objs_array(3, 2).col = 0
objs_array(3, 3).row = 1
objs_array(3, 3).col = -1
''type 2
objs_array(4, 0).row = -1
objs_array(4, 0).col = 0
objs_array(4, 1).row = 0
objs_array(4, 1).col = 0
objs_array(4, 2).row = 0
objs_array(4, 2).col = -1
objs_array(4, 3).row = 1
objs_array(4, 3).col = -1
objs_array(5, 0).row = 0
objs_array(5, 0).col = -1
objs_array(5, 1).row = 0
objs_array(5, 1).col = 0
objs_array(5, 2).row = 1
objs_array(5, 2).col = 0
objs_array(5, 3).row = 1
objs_array(5, 3).col = 1
objs_array(6, 0).row = -1
objs_array(6, 0).col = 0
objs_array(6, 1).row = 0
objs_array(6, 1).col = 0
objs_array(6, 2).row = 0
objs_array(6, 2).col = -1
objs_array(6, 3).row = 1
objs_array(6, 3).col = -1
objs_array(7, 0).row = 0
objs_array(7, 0).col = -1
objs_array(7, 1).row = 0
objs_array(7, 1).col = 0
objs_array(7, 2).row = 1
objs_array(7, 2).col = 0
objs_array(7, 3).row = 1
objs_array(7, 3).col = 1
''type 3
objs_array(8, 0).row = -1
objs_array(8, 0).col = 0
objs_array(8, 1).row = 0
objs_array(8, 1).col = 0
objs_array(8, 2).row = 0
objs_array(8, 2).col = 1
objs_array(8, 3).row = 1
objs_array(8, 3).col = 0
objs_array(9, 0).row = -1
objs_array(9, 0).col = 0
objs_array(9, 1).row = 0
objs_array(9, 1).col = 0
objs_array(9, 2).row = 0
objs_array(9, 2).col = -1
objs_array(9, 3).row = 0
objs_array(9, 3).col = 1
objs_array(10, 0).row = -1
objs_array(10, 0).col = 0
objs_array(10, 1).row = 0
objs_array(10, 1).col = 0
objs_array(10, 2).row = 0
objs_array(10, 2).col = -1
objs_array(10, 3).row = 1
objs_array(10, 3).col = 0
objs_array(11, 0).row = 0
objs_array(11, 0).col = -1
objs_array(11, 1).row = 0
objs_array(11, 1).col = 0
objs_array(11, 2).row = 0
objs_array(11, 2).col = 1
objs_array(11, 3).row = 1
objs_array(11, 3).col = 0
''type 4
objs_array(12, 0).row = 0
objs_array(12, 0).col = 0
objs_array(12, 1).row = 1
objs_array(12, 1).col = 0
objs_array(12, 2).row = 2
objs_array(12, 2).col = 0
objs_array(12, 3).row = 3
objs_array(12, 3).col = 0
objs_array(13, 0).row = 0
objs_array(13, 0).col = 0
objs_array(13, 1).row = 0
objs_array(13, 1).col = 1
objs_array(13, 2).row = 0
objs_array(13, 2).col = 2
objs_array(13, 3).row = 0
objs_array(13, 3).col = 3
objs_array(14, 0).row = 0
objs_array(14, 0).col = 0
objs_array(14, 1).row = 1
objs_array(14, 1).col = 0
objs_array(14, 2).row = 2
objs_array(14, 2).col = 0
objs_array(14, 3).row = 3
objs_array(14, 3).col = 0
objs_array(15, 0).row = 0
objs_array(15, 0).col = 0
objs_array(15, 1).row = 0
objs_array(15, 1).col = 1
objs_array(15, 2).row = 0
objs_array(15, 2).col = 2
objs_array(15, 3).row = 0
objs_array(15, 3).col = 3
''type 5
objs_array(16, 0).row = 0
objs_array(16, 0).col = 0
objs_array(16, 1).row = 0
objs_array(16, 1).col = 1
objs_array(16, 2).row = 1
objs_array(16, 2).col = 0
objs_array(16, 3).row = 1
objs_array(16, 3).col = 1
objs_array(17, 0).row = 0
objs_array(17, 0).col = 0
objs_array(17, 1).row = 0
objs_array(17, 1).col = 1
objs_array(17, 2).row = 1
objs_array(17, 2).col = 0
objs_array(17, 3).row = 1
objs_array(17, 3).col = 1
objs_array(18, 0).row = 0
objs_array(18, 0).col = 0
objs_array(18, 1).row = 0
objs_array(18, 1).col = 1
objs_array(18, 2).row = 1
objs_array(18, 2).col = 0
objs_array(18, 3).row = 1
objs_array(18, 3).col = 1
objs_array(19, 0).row = 0
objs_array(19, 0).col = 0
objs_array(19, 1).row = 0
objs_array(19, 1).col = 1
objs_array(19, 2).row = 1
objs_array(19, 2).col = 0
objs_array(19, 3).row = 1
objs_array(19, 3).col = 1
''type 6
objs_array(20, 0).row = -2
objs_array(20, 0).col = 0
objs_array(20, 1).row = -1
objs_array(20, 1).col = 0
objs_array(20, 2).row = 0
objs_array(20, 2).col = 0
objs_array(20, 3).row = 0
objs_array(20, 3).col = 1
objs_array(21, 0).row = -1
objs_array(21, 0).col = 0
objs_array(21, 1).row = 0
objs_array(21, 1).col = 0
objs_array(21, 2).row = 0
objs_array(21, 2).col = -1
objs_array(21, 3).row = 0
objs_array(21, 3).col = -2
objs_array(22, 0).row = 0
objs_array(22, 0).col = -1
objs_array(22, 1).row = 0
objs_array(22, 1).col = 0
objs_array(22, 2).row = 1
objs_array(22, 2).col = 0
objs_array(22, 3).row = 2
objs_array(22, 3).col = 0
objs_array(23, 0).row = 0
objs_array(23, 0).col = 0
objs_array(23, 1).row = 0
objs_array(23, 1).col = 1
objs_array(23, 2).row = 0
objs_array(23, 2).col = 2
objs_array(23, 3).row = 1
objs_array(23, 3).col = 0
''type 7
objs_array(24, 0).row = -2
objs_array(24, 0).col = 0
objs_array(24, 1).row = -1
objs_array(24, 1).col = 0
objs_array(24, 2).row = 0
objs_array(24, 2).col = 0
objs_array(24, 3).row = 0
objs_array(24, 3).col = -1
objs_array(25, 0).row = 0
objs_array(25, 0).col = -2
objs_array(25, 1).row = 0
objs_array(25, 1).col = -1
objs_array(25, 2).row = 0
objs_array(25, 2).col = 0
objs_array(25, 3).row = 1
objs_array(25, 3).col = 0
objs_array(26, 0).row = 0
objs_array(26, 0).col = 0
objs_array(26, 1).row = 0
objs_array(26, 1).col = 1
objs_array(26, 2).row = 1
objs_array(26, 2).col = 0
objs_array(26, 3).row = 2
objs_array(26, 3).col = 0
objs_array(27, 0).row = -1
objs_array(27, 0).col = 0
objs_array(27, 1).row = 0
objs_array(27, 1).col = 0
objs_array(27, 2).row = 0
objs_array(27, 2).col = 1
objs_array(27, 3).row = 0
objs_array(27, 3).col = 2
End If
Randomize
nex_obj.typ = Int(7 * Rnd)
nex_obj.stat = Int(4 * Rnd)
nex_obj.color = Int(8 * Rnd) + 3
nex_obj.pos = nextpos
cur_obj = nex_obj
prv_obj = cur_obj
Call obj_draw
Randomize
cur_obj.typ = Int(7 * Rnd)
cur_obj.stat = Int(4 * Rnd)
cur_obj.color = Int(8 * Rnd) + 3
cur_obj.pos = startpos
prv_obj = cur_obj
Call obj_draw
level = 1000
pulse = False
interval = 800
gaming = True
End Function
Public Function obj_left() '游戏对象向左移动，需判断是否超越左边界
Dim i As Long
Dim ii As Long
Dim nextcol As Long
Dim collide As Boolean
collide = False
nextcol = cur_obj.pos.col - 1
ii = cur_obj.typ * 4 + cur_obj.stat
For i = 0 To 3
If ((nextcol + objs_array(ii, i).col <= left) Or Cells(cur_obj.pos.row + objs_array(ii, i).row, nextcol + objs_array(ii, i).col) = " ") Then collide = True: Exit For
Next i
If (Not collide) Then
prv_obj = cur_obj
cur_obj.pos.col = nextcol
Call obj_draw
End If
End Function
Public Function obj_right() '游戏对象向右移动，需判断是否超越右边界
Dim i As Long
Dim ii As Long
Dim nextcol As Long
Dim collide As Boolean
collide = False
nextcol = cur_obj.pos.col + 1
ii = cur_obj.typ * 4 + cur_obj.stat
For i = 1 To 3
If ((nextcol + objs_array(ii, i).col >= right) Or Cells(cur_obj.pos.row + objs_array(ii, i).row, nextcol + objs_array(ii, i).col) = " ") Then collide = True: Exit For
Next i
If (Not collide) Then
prv_obj = cur_obj
cur_obj.pos.col = nextcol
Call obj_draw
End If
End Function
Public Function obj_change() '游戏对象下落形态的改变
Dim i As Long
Dim ii As Long
Dim iii As Long
Dim iiii As Long
Dim nextstat As Long
Dim nextcol As Long
Dim collide As Boolean
collide = False
nextstat = cur_obj.stat + 1
If (nextstat >= 4) Then
nextstat = nextstat Mod 4
End If
ii = cur_obj.typ * 4 + nextstat
nextcol = cur_obj.pos.col
If cur_obj.pos.col <= left + 3 Then
For i = 0 To 3
iii = left + 1 - cur_obj.pos.col - objs_array(ii, i).col
If (iii >= 0 And iii > iiii) Then iiii = iii
Next i
nextcol = nextcol + iiii
For i = 0 To 3
If Cells(cur_obj.pos.row + objs_array(ii, i).row, nextcol + objs_array(ii, i).col) = " " Then collide = True: Exit For
Next i
ElseIf cur_obj.pos.col >= right - 5 Then
For i = 0 To 3
iii = cur_obj.pos.col + objs_array(ii, i).col - right + 1
If (iii >= 0 And iii > iiii) Then iiii = iii
Next i
nextcol = nextcol - iiii
For i = 0 To 3
If Cells(cur_obj.pos.row + objs_array(ii, i).row, nextcol + objs_array(ii, i).col) = " " Then collide = True: Exit For
Next i
Else
For i = 0 To 3
If Cells(cur_obj.pos.row + objs_array(ii, i).row, nextcol + objs_array(ii, i).col) = " " Then collide = True: Exit For
Next i
End If
If Not collide Then
prv_obj = cur_obj
cur_obj.stat = nextstat
cur_obj.pos.col = nextcol
Call obj_draw
End If
End Function
Function obj_fall() '游戏对象下落
Dim i As Long
Dim ii As Long
Dim collide As Boolean
Dim j As Long
Dim k As Long
Dim nextrow As Long
collide = False
ii = cur_obj.typ * 4 + cur_obj.stat
nextrow = cur_obj.pos.row + 1
'判断是否下落到底
For i = 0 To 3
If (Cells(nextrow + objs_array(ii, i).row, cur_obj.pos.col + objs_array(ii, i).col) = " " Or nextrow + objs_array(ii, i).row >= bottom) Then collide = True: Exit For
Next i
If Not collide Then
prv_obj = cur_obj
cur_obj.pos.row = nextrow
Call obj_draw
Else
score = score + 10
score_level = 0
ii = cur_obj.typ * 4 + cur_obj.stat
For i = 0 To 3
Cells(cur_obj.pos.row + objs_array(ii, i).row, cur_obj.pos.col + objs_array(ii, i).col) = " "
Next i
If cur_obj.pos.row + objs_array(ii, 0).row < top Then
top = cur_obj.pos.row + objs_array(ii, 0).row
End If
'这里我偷懒用了一个不具通用性的方法判断每个方块像素所在行是否已满，若满后则消去这行
For i = 0 To 3
For j = left + 1 To right - 1
If Cells(cur_obj.pos.row + objs_array(ii, i).row, j) <> " " Then Exit For
Next j
If right - j <= 0 Then
Cells(cur_obj.pos.row + objs_array(ii, i).row, left + 1) = " "
score_level = score_level + 1
End If
Next i
If score_level > 0 Then
Dim l As Long
l = objs_array(ii, 3).row - objs_array(ii, 0).row
Dim tmp_array(3) As Long
For i = 0 To 3
tmp_array(i) = 0
Next i
'消去满的几行后把由消去的这几行以上到顶的所有像素向下移动
j = cur_obj.pos.row + objs_array(ii, 3).row
k = 0
For i = 0 To l
If Cells(j - i, left + 1) = " " Then
Range(Cells(j - i, left + 1), Cells(j - i, right - 1)).ClearContents
Range(Cells(j - i, left + 1), Cells(j - i, right - 1)).Interior.ColorIndex = 0
Else
Range(Cells(j - i, left + 1), Cells(j - i, right - 1)).Cut Destination:=Range(Cells(j - k, left + 1), Cells(j - k, right - 1))
k = k + 1
End If
Next i
l = cur_obj.pos.row + objs_array(ii, 0).row
If top < l Then
Range(Cells(top, left + 1), Cells(l - 1, right - 1)).Cut Destination:=Range(Cells(top + score_level, left + 1), Cells(l - 1 + score_level, right - 1))
End If
Range(Cells(top, left + 1), Cells(top + score_level - 1, right - 1)).ClearContents
Range(Cells(top, left + 1), Cells(top + score_level - 1, right - 1)).Interior.ColorIndex = 0
top = top + score_level
End If
score = score + 50 * score_level * (1 + score_level)
UserForm1.Label2.Caption = "Now you have the score of " + Str(score)
If score >= level Then
level = level + 800
interval = interval - 150
If interval < 50 Then
interval = 50
End If
If timerset <> 0 Then
timerset = KillTimer(0, timerset)
End If
pulse = False
End If
'判断方块是否堆积到顶，若未则生成下一方块，否则游戏结束
If top > mosttop Then
Call reinitial: Exit Function
Else: Call game_over: Exit Function
End If
End If
End Function
Function obj_draw()
Dim i As Long
Dim ii As Long
ii = prv_obj.typ * 4 + prv_obj.stat
For i = 0 To 3
Cells(prv_obj.pos.row + objs_array(ii, i).row, prv_obj.pos.col + objs_array(ii, i).col).Interior.ColorIndex = 0
Next i
ii = cur_obj.typ * 4 + cur_obj.stat
For i = 0 To 3
Cells(cur_obj.pos.row + objs_array(ii, i).row, cur_obj.pos.col + objs_array(ii, i).col).Interior.ColorIndex = cur_obj.color
Next i
End Function
Function reinitial()
If gaming Then
prv_obj = nex_obj
Randomize
nex_obj.typ = Int(7 * Rnd)
nex_obj.stat = Int(4 * Rnd)
nex_obj.color = Int(8 * Rnd) + 3
nex_obj.pos = nextpos
cur_obj = nex_obj
Call obj_draw
cur_obj = prv_obj
cur_obj.pos = startpos
prv_obj = cur_obj
Call obj_draw
End If
End Function
Function game_over()
If timerset <> 0 Then
timerset = KillTimer(0, timerset)
End If
If MsgBox("Try it again?", vbOKCancel, "Game over temporarily") = vbOK Then
Cells.ClearContents
Cells.Interior.ColorIndex = 0
Call game_initial
Else
Cells.ClearContents
Cells.Interior.ColorIndex = 0
gaming = False
SendKeys "%{F4}"
End If
End Function
Public Sub pulse_()
If gaming Then
Call obj_fall
End If
End Sub
以上是宏部分的代码，下面引入窗体后键入如下代码
Private Sub UserForm_Initialize()
Label1.Caption = "NO PLAY,NO GAME"
Call game_initial
If (gaming) Then
Label2.Caption = "Move and change by ARROW keys. Pause the game by P and end it by E"
Else
Label2.Caption = "Something happened. It needs to do something"
Call game_over
End If
End Sub
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If gaming Then
If Not pulse Then
pulse = True
timerset = SetTimer(0, 0, interval, AddressOf pulse_)
Label2.Caption = "Move and change by ARROW keys. Pause the game by P and end it by E"
End If
Select Case KeyCode
Case vbKeyLeft
Call obj_left
Case vbKeyRight
Call obj_right
Case vbKeyUp
Call obj_change
Case vbKeyDown
Call obj_fall
Case vbKeyP '销毁定时器，游戏暂停
If timerset <> 0 Then
timerset = KillTimer(0, timerset)
pulse = False
End If
Label2.Caption = "Game Paused.You can resume by ANY key"
Case vbKeyE
Call game_over
End Select
End If
End Sub
Private Sub UserForm_Terminate()
MsgBox ("You have complete the game with the score of " + Str(score))
Worksheets(1).Select
End Sub
有问题再发问吧，我都忘得七七八八了。 
|
本类阅读TOP10