📄 form1.frm
字号:
VERSION 5.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "迷宫寻径"
ClientHeight = 7920
ClientLeft = 48
ClientTop = 336
ClientWidth = 9804
Icon = "Form1.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 660
ScaleMode = 3 'Pixel
ScaleWidth = 817
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton cmdCls
Caption = "清扫脚印"
Height = 420
Left = 7875
TabIndex = 12
Top = 2610
Width = 1590
End
Begin VB.CommandButton cmdAbout
Caption = "关于"
Height = 420
Left = 7875
TabIndex = 11
Top = 6930
Width = 1590
End
Begin VB.CheckBox chkShowSearch
Caption = "显示搜索过程"
Height = 225
Left = 7875
TabIndex = 9
Top = 3555
Width = 1545
End
Begin VB.CommandButton cmdPen
Caption = "画笔"
Height = 420
Left = 7875
TabIndex = 8
Top = 1530
Width = 1590
End
Begin VB.PictureBox picBack
Appearance = 0 'Flat
BackColor = &H80000000&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 7710
Left = 90
ScaleHeight = 643
ScaleMode = 3 'Pixel
ScaleWidth = 631
TabIndex = 6
Top = 90
Width = 7575
Begin VB.PictureBox picMain
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H00C0FFC0&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 7050
Left = 225
ScaleHeight = 588
ScaleMode = 3 'Pixel
ScaleWidth = 588
TabIndex = 7
Top = 315
Width = 7050
End
End
Begin VB.ListBox lstRst
Appearance = 0 'Flat
Height = 2364
Left = 7875
TabIndex = 4
Top = 4275
Width = 1590
End
Begin VB.TextBox txtCellNum
Height = 285
Left = 8685
TabIndex = 3
Text = "15"
Top = 3150
Width = 690
End
Begin VB.CommandButton cmdErase
Caption = "橡皮擦"
Height = 420
Left = 7875
TabIndex = 2
Top = 2070
Width = 1590
End
Begin VB.CommandButton cmdCal
Caption = "计算路线"
Height = 420
Left = 7875
TabIndex = 1
Top = 990
Width = 1590
End
Begin VB.CommandButton cmdInit
Caption = "生成空地"
Height = 420
Left = 7875
TabIndex = 0
Top = 450
Width = 1590
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "行列数："
Height = 180
Left = 7875
TabIndex = 10
Top = 3195
Width = 720
End
Begin VB.Label lblMsg
AutoSize = -1 'True
Caption = "Label1"
Height = 180
Left = 7875
TabIndex = 5
Top = 3960
Width = 540
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'走迷宫 V1.0
'作者：追梦人 KIKIKAKI
'2007年8月8日
'迷宫数组
'0-代表可以通行
'1-代表不通
'2-代表已经探索
Option Explicit
Private Type ExpPos
ExpX As Byte
ExpY As Byte
End Type
Private Type MStack
St() As ExpPos
StackPos As Integer
End Type
Dim MazeStack As MStack '搜索迷宫的栈
Dim ResultStack As MStack '路径结果
Dim Maze() As Byte '代表迷宫的数组
Dim MouIsDown As Boolean '鼠标是否按下
Dim N As Byte '单元格数目
Dim Tim As Long '开始计算前的时间
Dim PenState As Boolean '画笔状态或橡皮状态
'图片框宽度标准化
Private Sub CalPicWid()
Dim PicWid As Integer
Dim CellWid As Integer
PicWid = 470
CellWid = PicWid / N
PicWid = CellWid * N
With picMain
.Width = PicWid + 1
.Height = PicWid + 1
.Left = (picBack.Width - .Width) / 2
.Top = (picBack.Height - .Height) / 2
End With
End Sub
'绘制空地
Private Sub PaintGround()
Dim I As Byte
Dim PicWid As Integer
Dim CellWid As Integer '单元格宽度
PicWid = picMain.Width
CellWid = PicWid / N
picMain.Cls
'绘制起点和终点
picMain.Line (0, 0)-(CellWid, CellWid), vbGreen, BF
picMain.Line (CellWid * (N - 1), CellWid * (N - 1))-(CellWid * N, CellWid * N), vbGreen, BF
For I = 0 To N
picMain.Line (CellWid * I, 0)-(CellWid * I, PicWid)
Next I
For I = 0 To N
picMain.Line (0, CellWid * I)-(PicWid, CellWid * I)
Next I
'picMain.Line (0, CellWid * N - 1)-(CellWid * N, CellWid * N - 1)
'picMain.Line (CellWid * N - 1, 0)-(CellWid * N - 1, CellWid * N)
End Sub
'将迷宫数组转化成图形
Private Sub PaintMaze()
Dim I As Integer, J As Integer
Dim CellWid As Integer
CellWid = picMain.Width / N
For J = 1 To N
For I = 1 To N
If Maze(I, J) = 1 Then
picMain.Line (CellWid * (I - 1) + 1, CellWid * (J - 1) + 1)-(CellWid * I - 1, CellWid * J - 1), &H8000&, BF
End If
Next I
Next J
End Sub
'画出路径
Private Sub PaintPath()
Dim CX As Byte, CY As Byte
Dim PicWid As Integer
Dim CellWid As Integer
lstRst.Clear
PicWid = picMain.Width
CellWid = PicWid / N
Call PopStack(ResultStack, CX, CY)
picMain.Line (CellWid * (CX - 1) + 1, CellWid * (CY - 1) + 1)-(CellWid * CX - 1, CellWid * CY - 1), &HFF8888, BF
lstRst.AddItem "(" & CX & "," & CY & ")"
Do While Not IsStackEmpty(ResultStack)
Call PopStack(ResultStack, CX, CY)
picMain.Line (CellWid * (CX - 1) + 1, CellWid * (CY - 1) + 1)-(CellWid * CX - 1, CellWid * CY - 1), &HFF8888, BF
lstRst.AddItem "(" & CX & "," & CY & ")"
Loop
picMain.Line (1, 1)-(CellWid - 1, CellWid - 1), vbGreen, BF
'Call PaintCellNum
End Sub
'初始化迷宫数组
Private Sub InitData()
Dim I As Integer, J As Integer
ReDim Maze(N + 1, N + 1) As Byte
For J = 0 To N + 1
For I = 0 To N + 1
Maze(I, J) = 1
Next I
Next J
For J = 1 To N
For I = 1 To N
Maze(I, J) = 0
Next I
Next J
Maze(1, 1) = 3
Maze(N, N) = 3
End Sub
'在迷宫上显示数字
Private Sub PaintCellNum()
Dim I As Integer, J As Integer
For J = 0 To N + 1
For I = 0 To N + 1
picMain.CurrentX = picMain.Width / N * (I - 1)
picMain.CurrentY = picMain.Width / N * (J - 1)
picMain.Print Maze(I, J)
picMain.CurrentX = picMain.Width / N * (I - 1)
picMain.CurrentY = picMain.Width / N * (J - 1) + 10
picMain.Print "(" & CStr(I) & "," & CStr(J) & ")"
Next I
Next J
End Sub
'初始化迷宫
Private Sub InitMaze()
picMain.Cls
Call CalPicWid
Call PaintGround
Call InitData
'Call PaintCellNum
lblMsg.Caption = "初始化完毕！"
End Sub
'清空栈
Private Function ClsStack(Stack As MStack) As Boolean
On Error GoTo ErrHandle
ReDim Stack.St(0) '清空迷宫数据
Stack.StackPos = 0 '栈指针复位
ClsStack = True
Exit Function
ErrHandle:
ClsStack = False
End Function
'入栈
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -