该楼层疑似违规已被系统折叠 隐藏此楼查看此楼
'!!!注意了,先把窗体的BorderStyle属性设为0-None(否则有bug),然后直接粘贴代即可
'游戏控制:ESC键退出游戏.←,↑,→,↓或A,W,D,S键控制方向,暂停还没想好怎么写
'本想将程序美化后再发出来(比如给字符上上色,加点菜单或按钮什么的),但这对于代码的交流似乎没有好处...(没有按书写规范,见谅)
'代码中如有bug希望大家指出
'代码若能优化或简化之处请高手指点,非常感谢
'本人业余爱好者,QQ:305349746
Option Explicit
Option Base 1
Dim WithEvents Tim As Timer '计时器
Dim row, col As Integer '行,列数
Dim r As Single '步距(字符高度)
Dim Txt As String '句子
Dim Word() As String '单字
Dim A() '字符的地址
Dim PNum As Integer '实时显示字符数
Dim n As Integer '计数器
Dim DirCode As Integer '决定着蛇头的运动方向
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If (KeyCode = 27) Then End '按ESC键退出游戏
Select Case DirCode
Case 37, 39, 65, 68 '当按下←或→键是再按←→键无效
Select Case KeyCode
Case 38, 40, 87, 83
DirCode = KeyCode
End Select
Case 38, 40, 87, 83 '当按下↑或↓键是再按↑↓键无效
Select Case KeyCode
Case 37, 39, 65, 68
DirCode = KeyCode
End Select
End Select
End Sub
Private Sub Form_Load()
Randomize (Timer)
Me.Caption = "▲您应该先把form1的BorderStyle属性设为0-None,否则有小bug--lyxue)"
Me.AutoRedraw = True
Set Tim = Controls.Add("VB.Timer", "Tim", Me) '计时器
Tim.Interval = 250 '游戏速度相关
Me.FontName = "黑体" '字体
Me.FontSize = 15 '字符大小
r = Me.TextHeight("蛇") '步距大小(字高)
row = 31: col = 15 '行,列数(点阵数=行*列)
Me.Width = r * row: Me.Height = r * col '场地大小
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2 '居中显示
Dim t '输入一句话,化成一条蛇:
Do
Txt = ""
t = InputBox("游戏开始前,先在下框中输入一句您想说的话吧:" & Chr(13) & Chr(13) & "**下框中的汉字可能无法正常显示,但游戏开始后恢复正常**", "游戏开始前", "君不见*垓下帐里虞姬伤*章台柳下摇满霜*长恨歌里恨见长*沈园小径空留香*又何妨*苦乐相参本无常*知音能得几回赏*明月沟渠各一方*戍客何必尽望乡")
For n = 1 To Len(t)
Txt = Txt & IIf(Mid(t, n, 1) = " ", "", Mid(t, n, 1))
Next n
If Txt = "" Then
End
ElseIf Len(Txt) < 3 Then
n = MsgBox(Len(Txt) & "个字符也太少了点吧,请您重新输入" & Chr(13) & Chr(13) & " (不计空格,至少要输入3个字符)", 0, "提示")
End If
Loop While Len(Txt) < 3
ReDim Word(Len(Txt)), A(Len(Txt), 2) '根据字符个数把蛇分为若干段(数组变量A(num1,num2)用于存储每段蛇身的坐标,其中num1说明是蛇身的第几截,num2若为1,表示X坐标,若为2,表示Y坐标)
For n = 1 To Len(Txt)
Word(n) = Mid(Txt, n, 1) '把句子中的每个字符赋予变量(句子中每个字符都是蛇身的一部分)
Next n
A(1, 1) = 0: A(1, 2) = 0 '蛇头的初始地址
DirCode = 39 '决定初始方向
PNum = 2 '刚开始只显示两个字符
Call Food '添加第2个字符(第一个食物)
End Sub
Sub Food() '添加新食物,这段循环让我崇拜自己好一阵...(高手别笑)
Do
A(PNum, 1) = Int(Rnd * row) * r: A(PNum, 2) = Int(Rnd * col) * r '随机分配新食物的位置
For n = 1 To PNum - 1
If (A(PNum, 1) = A(n, 1)) * (A(PNum, 2) = A(n, 2)) Then Exit For '逐个检查,若食物刚好落在蛇身上,则重新机选食物的位置
Next n
Loop Until n = PNum '若食物没落在蛇身上则退出循环
End Sub
Private Sub Tim_Timer()
'刷新显示
Cls
For n = 1 To PNum
CurrentX = A(n, 1): CurrentY = A(n, 2)
Print Word(n)
Next n
If (A(1, 1) + r <= 0) + (A(1, 2) + r <= 10) + (A(1, 1) >= Me.Width) + (A(1, 2) >= Me.Height) Then GameOver ("您的蛇蛇撞破头了--lyxue") '如果撞墙则游戏结束
'蛇头与其它字符相接触判断:如果撞到蛇身则游戏结束,如果吃到到食物就把食物变成新的尾巴
For n = 2 To PNum
If (A(1, 1) = A(n, 1)) * (A(1, 2) = A(n, 2)) Then
If n <> PNum Then '撞到蛇身则游戏结束
GameOver ("您的蛇蛇把自己给咬了--lyxue")
ElseIf n = Len(Txt) Then '游戏胜利
GameOver ("恭喜,您胜利啦!")
ElseIf n = PNum Then '吃到食物则显示的字符数加1(新的食物)
PNum = PNum + 1
Call Food '添加新食物
End If
End If
Next n
'蛇身向前移动一格
For n = PNum - 2 To 1 Step -1
A(n + 1, 1) = A(n, 1): A(n + 1, 2) = A(n, 2)
Next n
'决定蛇头运动方向:
Select Case DirCode
Case 37, 65
A(1, 1) = A(1, 1) - r '向左运动
Case 38, 87
A(1, 2) = A(1, 2) - r '向上运动
Case 39, 68
A(1, 1) = A(1, 1) + r '向右运动
Case 40, 83
A(1, 2) = A(1, 2) + r '向下运动
End Select
End Sub
Sub GameOver(t As String)
Tim.Interval = 0
Cls
Me.FontSize = 30
Me.ForeColor = vbRed
CurrentX = (Me.Width - Me.TextWidth(t)) / 2
CurrentY = (Me.Height - Me.TextHeight(t)) / 2
Print t
End Sub