迷宫,简单游戏
不想说什么了，迷宫产生部分是网上找的，然后把它拆成二个部分，然后再加上游戏部分就是了。整个代码如下：
程序代码：Option Explicit
'Dim A(1001, 1001)
Dim A()
Dim mx As Long
Dim my As Long
Private Const 格子大小 = 500
Private Const 边距 = 500
Dim Rx As Long, Ry As Long
Dim RB As Long
Private Sub Command1_Click()
Call 产生迷宫(Int(Picture1.ScaleWidth / 500) * 500 - 1000, Int(Picture1.ScaleHeight / 500) * 500 - 1000, Picture1)
Picture1.SetFocus
End Sub
Private Sub 产生迷宫(szx As Long, szy As Long, obj As Object)
'Dim szx As Long
'Dim szy As Long
'Dim tr As Long
'Dim l As Long
Dim i As Long
Dim x As Long
Dim y As Long
Dim s As Long
Dim xx As Long
Dim yy As Long
Dim R As Long
Dim q As Long, p As Long
Dim qq As Long, pp As Long
Dim t As Long
'szx = 10000 '整个迷宫的长
'szy = 15000 '整个迷宫的宽
'tr = 500 '离左，上边的距离
'l = 500 '格子的大小
mx = szx / 格子大小
my = szy / 格子大小
ReDim A(mx + 1, my + 1)
For i = 0 To mx + 1 '给边边赋值-1
A(i, 0) = -1
A(i, my + 1) = -1
Next
For i = 0 To my + 1
A(0, i) = -1
A(mx + 1, i) = -1
Next
x = mx - 1
y = my
s = 1
A(x, y) = s
'此段是网上找的代码
Do While Not (x = 2 And y = 1) '从右下角开始 寻找一条路径到左上角，每经过一个点就赋值s s会自己累加
If A(x - 1, y) = 0 Or A(x, y - 1) = 0 Or A(x, y + 1) = 0 Or A(x + 1, y) = 0 Then
Do Until A(xx, yy) = 0
R = Int(Rnd(1) * 4)
xx = x + (R = 0) - (R = 2)
yy = y + (R = 1) - (R = 3)
Loop
x = xx
y = yy
s = s + 1
A(x, y) = s
Else
For i = 0 To 3
xx = x + (i = 0) - (i = 2)
yy = y + (i = 1) - (i = 3)
If A(xx, yy) = s - 1 Then
x = xx
y = yy
s = A(x, y)
Exit For
End If
Next
End If
'Call VIEW(Me) 'DEUBG
Loop
For q = my To 1 Step -1 '扫描所有的点 找到值为1以下的点
For p = mx To 1 Step -1
If A(p, q) > 0 Then
Else
Do
R = Int(Rnd(1) * 4)
pp = p + (R = 0) - (R = 2)
qq = q + (R = 1) - (R = 3)
Loop Until A(pp, qq) >= 1
x = p
y = q
s = A(pp, qq) * 2 + 1000
A(x, y) = s
Do While Not (x = 2 And y = 1) '从找到的点 开始寻找路径到左上角，没路的话就跳出 并给经过的点赋值s
If A(x - 1, y) = 0 Or A(x, y - 1) = 0 Or A(x, y + 1) = 0 Or A(x + 1, y) = 0 Then
Do Until A(xx, yy) = 0
R = Int(Rnd(1) * 4)
xx = x + (R = 0) - (R = 2)
yy = y + (R = 1) - (R = 3)
Loop
x = xx
y = yy
s = s + 1
A(x, y) = s
Else
For i = 0 To 3
xx = x + (i = 0) - (i = 2)
yy = y + (i = 1) - (i = 3)
If A(xx, yy) = s - 1 Then
x = xx
y = yy
s = A(x, y)
Exit For
End If
Next
Exit Do
End If
Loop
End If
Next
Next
'定义出口,以便直接输出出口的位置,不需要擦线
A(mx - 1, my + 1) = 0 '出口
'小人位置
Rx = 2
Ry = 1
RB = 0
'显示
Call VIEW(obj)
End Sub
Private Sub Command2_Click()
Call VIEW(Picture1)
'这句是打印迷宫的命令,A4纸横放的默认打印机
' Call 产生迷宫(10000, 15000, Printer)
End Sub
Public Sub VIEW(obj As Object)
'显示迷宫
Dim x As Long, y As Long
Dim t As Long
If Not obj Is Printer Then
obj.Cls
End If
For x = 1 To mx '从左上角开始向下和向右扫描每个点的值，假如是同一路径的点就不画线 其他画线
For y = 1 To my
'DEBUG 用
' obj.CurrentX = x * 格子大小 + 边距 - 格子大小
' obj.CurrentY = y * 格子大小 + 边距 - 格子大小
' obj.Print A(x, y)
'这个判断,没弄懂怎么来的,注意这个判断里有时有问题,但情况极少
t = Abs(A(x, y) - A(x + 1, y))
If t <= 1 Or t - 1000 = A(x, y) Or t - 1000 = A(x + 1, y) Then
Else
obj.Line (x * 格子大小 + 边距, y * 格子大小 - 格子大小 + 边距)-(x * 格子大小 + 边距, y * 格子大小 + 边距)
End If
'上面是向下的判断,这个是向右的判断
t = Abs(A(x, y) - A(x, y + 1))
If t <= 1 Or t - 1000 = A(x, y) Or t - 1000 = A(x, y + 1) Then
Else
obj.Line (x * 格子大小 - 格子大小 + 边距, y * 格子大小 + 边距)-(x * 格子大小 + 边距, y * 格子大小 + 边距)
End If
Next
Next
'obj.Line (tr, tr)-(tr + szx, tr + szy), , B '画整个迷宫的边框
obj.Line (边距, 边距)-(边距 + 边距, 边距) '画最上面那根线的左边部分
obj.Line (边距 + 2 * 边距, 边距)-(边距 + mx * 格子大小, 边距) '画最上面那根线的右边部分
obj.Line (边距, 边距)-(边距, 边距 + my * 格子大小) '画迷宫的最左边那根线
'原来采用清除的办法画出口,如果是打印的话,此方法有问题,取消
'obj.Line (L + tr, tr)-(L + L + tr, tr), &H8000000F '画迷宫的入口
'obj.Line (szx - L + tr, szy + tr)-(szx - L - L + tr, szy + tr), &H8000000F '画迷宫的出口
If obj Is Printer Then
obj.EndDoc
End If
Call 显示小人
DoEvents
End Sub
Private Sub Command3_Click()
Call VIEWEND
End Sub
Private Sub VIEWEND()
'显示从入口到结束的路线
Dim i As Long
Dim x As Long
Dim y As Long
Dim x1 As Long
Dim y1 As Long
Dim 半格 As Long
半格 = 格子大小 / 2
i = A(2, 1)
x = 2
y = 0
x1 = 2
y1 = 1
'从外面画到入口
Picture1.Line (边距 + x * 格子大小 - 半格, 边距 + y * 格子大小 - 半格)-(边距 + x1 * 格子大小 - 半格, 边距 + y1 * 格子大小 - 半格), RGB(255, 0, 0)
x = 2
y = 1
'搜索方位,
Do While i > 0
If A(x - 1, y) = i - 1 Then
x1 = x - 1
y1 = y
i = i - 1
End If
If A(x + 1, y) = i - 1 Then
x1 = x + 1
y1 = y
i = i - 1
End If
If A(x, y - 1) = i - 1 Then
x1 = x
y1 = y - 1
i = i - 1
End If
If A(x, y + 1) = i - 1 Then
x1 = x
y1 = y + 1
i = i - 1
End If
Picture1.Line (边距 + x * 格子大小 - 半格, 边距 + y * 格子大小 - 半格)-(边距 + x1 * 格子大小 - 半格, 边距 + y1 * 格子大小 - 半格), RGB(255, 0, 0)
x = x1
y = y1
Loop
End Sub
Private Sub Command4_Click()
'小人位置
Rx = 2
Ry = 1
RB = 0
Call VIEW(Picture1)
End Sub
Private Sub Form_Load()
Randomize Timer
End Sub
Private Sub Form_Resize()
On Error Resume Next
Picture1.Move Picture1.Left, Picture1.Top, Me.ScaleWidth - Picture1.Left - Picture1.Left, Me.ScaleHeight - Picture1.Top - 64
End Sub
Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer)
'MsgBox KeyCode
Dim x As Long, y As Long
Dim 半格 As Long
半格 = 格子大小 / 2
Dim t As Long
x = Rx
y = Ry
'方向键,并记录步数
Select Case KeyCode
Case vbKeyLeft
x = x - 1
RB = RB + 1
Case vbKeyRight
x = x + 1
RB = RB + 1
Case vbKeyUp
y = y - 1
RB = RB + 1
Case vbKeyDown
y = y + 1
RB = RB + 1
End Select
If x > 0 And y > 0 And x <= mx And y <= my Then
'判断是否能通过,使用了前面看不懂的判断
t = Abs(A(Rx, Ry) - A(x, y))
If t <= 1 Or t - 1000 = A(Rx, Ry) Or t - 1000 = A(x, y) Then
Picture1.Line (边距 + Rx * 格子大小 - 半格, 边距 + Ry * 格子大小 - 半格)- _
(边距 + x * 格子大小 - 半格, 边距 + y * 格子大小 - 半格), RGB(0, 255, 0) '此行分成二行写
Rx = x
Ry = y
Call 显示小人
End If
End If
End Sub
Private Sub 显示小人()
Dim i As Long
Image1.Move 边距 + Rx * 格子大小 - 格子大小 + 100, 边距 + Ry * 格子大小 - 格子大小 + 100
Label1.Caption = RB & " / " & A(2, 1) - 1
If Rx = mx - 1 And Ry = my Then
MsgBox "祝贺你走出了这个迷宫,你的成绩是 " & RB & " 步，本迷宫最佳路线是 " & A(2, 1) - 1 & " 步。", vbInformation
End If
End Sub
迷宫.rar
