求vb小游戏代码 谢谢

Answer 1

直接复制下面代码到代码框中后运行程序即可：

Option Explicit
Private WithEvents Timer1 As Timer
Private WithEvents Label1 As Label
Dim GFangXiang As Boolean
Dim HWB As Single
Dim She() As ShenTi
Dim X As Long, Y As Long
Dim ZhuangTai(23, 23) As Long
Private Type ShenTi
F As Long
X As Long
Y As Long
End Type

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim C As Long
If KeyCode = 27 Then End
If KeyCode = 32 Then
If Timer1.Enabled = True Then
Timer1.Enabled = False
Label1.Visible = True
Else
Timer1.Enabled = True
Label1.Visible = False
End If
End If
C = UBound(She)
If GFangXiang = True Then Exit Sub
Select Case KeyCode
Case 37
If She(C).F = 2 Then Exit Sub
She(C).F = 0
GFangXiang = True
Case 38
If She(C).F = 3 Then Exit Sub
She(C).F = 1
GFangXiang = True
Case 39
If She(C).F = 0 Then Exit Sub
She(C).F = 2
GFangXiang = True
Case 40
If She(C).F = 1 Then Exit Sub
She(C).F = 3
GFangXiang = True
End Select
End Sub

Private Sub Form_Load()
Me.AutoRedraw = True
Me.BackColor = &HC000&
Me.FillColor = 255
Me.FillStyle = 0
Me.ScaleWidth = 24
Me.ScaleHeight = 24
Me.WindowState = 2
Set Timer1 = Controls.Add("VB.Timer", "Timer1")
Set Label1 = Controls.Add("VB.Label", "Label1")
Label1.AutoSize = True
Label1.BackStyle = 0
Label1 = "暂停"
Label1.ForeColor = RGB(255, 255, 0)
Label1.FontSize = 50
ChuShiHua
End Sub

Private Sub Form_Resize()
On Error GoTo 1:
With Me
If .WindowState <> 1 Then
.Cls
.ScaleMode = 3
HWB = .ScaleHeight / .ScaleWidth
.ScaleWidth = 24
.ScaleHeight = 24
Label1.Move (Me.ScaleWidth - Label1.Width) / 2, (Me.ScaleHeight - Label1.Height) / 2
HuaTu
Me.Line (X, Y)-(X + 1, Y + 1), RGB(255, 255, 0), BF
End If
End With
1:
End Sub

Private Sub Timer1_Timer()
Dim C As Long, I As Long
On Error GoTo 2:
QingChu
C = UBound(She)
Select Case She(C).F
Case 0
If ZhuangTai(She(C).X - 1, She(C).Y) = 2 Then
C = C + 1
ReDim Preserve She(C)
She(C).F = She(C - 1).F
She(C).X = She(C - 1).X - 1
She(C).Y = She(C - 1).Y
ChanShengShiWu
GoTo 1:
ElseIf ZhuangTai(She(C).X - 1, She(C).Y) = 1 Then
GoTo 2:
End If
Case 1
If ZhuangTai(She(C).X, She(C).Y - 1) = 2 Then
C = C + 1
ReDim Preserve She(C)
She(C).F = She(C - 1).F
She(C).X = She(C - 1).X
She(C).Y = She(C - 1).Y - 1
ChanShengShiWu
GoTo 1:
ElseIf ZhuangTai(She(C).X, She(C).Y - 1) = 1 Then
GoTo 2:
End If
Case 2
If ZhuangTai(She(C).X + 1, She(C).Y) = 2 Then
C = C + 1
ReDim Preserve She(C)
She(C).F = She(C - 1).F
She(C).X = She(C - 1).X + 1
She(C).Y = She(C - 1).Y
ChanShengShiWu
GoTo 1:
ElseIf ZhuangTai(She(C).X + 1, She(C).Y) = 1 Then
GoTo 2:
End If
Case 3
If ZhuangTai(She(C).X, She(C).Y + 1) = 2 Then
C = C + 1
ReDim Preserve She(C)
She(C).F = She(C - 1).F
She(C).X = She(C - 1).X
She(C).Y = She(C - 1).Y + 1
ChanShengShiWu
GoTo 1:
ElseIf ZhuangTai(She(C).X, She(C).Y + 1) = 1 Then
GoTo 2:
End If
End Select
ZhuangTai(She(0).X, She(0).Y) = 0
For I = 0 To C
Select Case She(I).F
Case 0
She(I).X = She(I).X - 1
Case 1
She(I).Y = She(I).Y - 1
Case 2
She(I).X = She(I).X + 1
Case 3
She(I).Y = She(I).Y + 1
End Select
Next
TiaoZheng
1:
GFangXiang = False
ZhuangTai(She(C).X, She(C).Y) = 1
HuaTu
Exit Sub
2:
If MsgBox("游戏结束，点“是”重新开始游戏，点“否”", vbYesNo, "贪吃蛇") = vbYes Then
ChuShiHua
Else
End
End If
End Sub

Private Sub ChuShiHua()
Me.Cls
Timer1.Enabled = True
Timer1.Interval = 200
Erase ZhuangTai
ReDim She(2)
She(0).F = 2
She(0).X = 9
She(0).Y = 11
ZhuangTai(9, 11) = 1
She(1).F = 2
She(1).X = 10
She(1).Y = 11
ZhuangTai(10, 11) = 1
She(2).F = 2
She(2).X = 11
She(2).Y = 11
ZhuangTai(11, 11) = 1
HuaTu
ChanShengShiWu
End Sub

Private Sub QingChu()
Dim I As Long
For I = 0 To UBound(She)
Me.Line (She(I).X, She(I).Y)-(She(I).X + 1, She(I).Y + 1), Me.BackColor, BF
Next
End Sub

Private Sub HuaTu()
Dim I As Long
For I = 0 To UBound(She)
Me.Circle (She(I).X + 0.5, She(I).Y + 0.5), 0.49, RGB(255, 255, 0), , , HWB
Next
End Sub

Private Sub TiaoZheng()
Dim I As Long
For I = 0 To UBound(She) - 1
She(I).F = She(I + 1).F
Next
End Sub

Private Sub ChanShengShiWu()
Randomize Timer
1:
X = Int(Rnd * 24)
Y = Int(Rnd * 24)
If ZhuangTai(X, Y) > 0 Then GoTo 1:
ZhuangTai(X, Y) = 2
Me.Line (X, Y)-(X + 1, Y + 1), RGB(255, 255, 0), BF
End Sub

追问

有没的打包的嘛 谢谢 有请发到我邮箱836415640@qq.com 谢谢

追答

已发送，请查收！
我都发给你两个了怎么还不采纳？

Answer 2

工程我已发
Dim b(0 To 8)
Dim m, k, n
Private Sub Command1_Click()
a = "012345678"
For i = 0 To 8
Randomize
temp = Int(Rnd * Len(a) + 1)
Label1.Caption = 40
If i <= 1 Then
b(Mid(a, temp, 1)) = "red"
ElseIf i > 1 And i <= 3 Then
b(Mid(a, temp, 1)) = "blue"
ElseIf i > 3 And i <= 5 Then
b(Mid(a, temp, 1)) = "green"
ElseIf i > 5 And i <= 7 Then
b(Mid(a, temp, 1)) = "cyan"
ElseIf i = 8 Then
b(Mid(a, temp, 1)) = "black"
End If
a = Replace(a, Mid(a, temp, 1), "")
Next
Timer1.Enabled = True
For i = 0 To 8
Text1(i).Visible = True
Next
End Sub

Private Sub Form_Load()
n = "1"
For i = 0 To 8
Text1(i).Visible = False
Text1(i).BackColor = vbWhite
Text1(i).Enabled = True

Next
End Sub

Private Sub Text1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
If n = 1 Then
m = Index
n = 2
Else
k = Index
Timer2.Enabled = True
End If
If b(Index) = "red" Then
Text1(Index).BackColor = vbRed
ElseIf b(Index) = "blue" Then
Text1(Index).BackColor = vbBlue
ElseIf b(Index) = "green" Then
Text1(Index).BackColor = vbGreen
ElseIf b(Index) = "cyan" Then
Text1(Index).BackColor = vbCyan
ElseIf b(Index) = "black" Then
Text1(Index).BackColor = vbBlack
End If
End Sub

Private Sub Timer1_Timer()
If Label1.Caption <> 0 Then Label1.Caption = Label1.Caption - 1
If Label1.Caption = 0 Then
d = MsgBox("是否重新开始", vbYesNo, "失败")
If d = vbYes Then
Call Form_Load
Call Command1_Click
Else
Timer1.Enabled = False
End If
End If

For d = 0 To 8
If Controls("text1")(d).Enabled = False Then e = e + 1
Next
If e = 8 Then
d = MsgBox("是否重新开始", vbYesNo, "成功")

If d = vbYes Then
e = 0
Call Form_Load
Call Command1_Click
Else
Timer1.Enabled = False
End If

End If
End Sub

Private Sub Timer2_Timer()
If b(m) = b(k) Then
Text1(m).Enabled = False
Text1(k).Enabled = False
Else
Text1(m).BackColor = vbWhite
Text1(k).BackColor = vbWhite
End If
n = 1
Timer2.Enabled = False

End Sub