应用所学写了一只程式 让它可以自己产生迷宫 用乱数产生墙 用滑鼠点击修改墙 清空墙 重新设定墙 等等功能 想问问各位前辈还有没有可以优化的地方 BUG在请人玩了以後应该是没有甚麽BUG了 另外inputbox不输入东西按X会整个程式跳掉有办法解决吗@@ 这是包装好的程式:http://ppt.cc/!NPc 以下原始码: form1.frm Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public xd As Integer Public yd As Integer Const bound As Integer = 1500 '边界值 Public num As Long '格子数 Public seed As Long '种子数 Dim map() As Obj Private Sub Command1_Click() ans Command1.Enabled = False End Sub Private Sub Command2_Click() seed = InputBox("请输入障碍物数量") Do While 1 > seed Or seed > num * num - 1 MsgBox "输入有误 数字限制在1~" & num * num - 1 seed = InputBox("请输入障碍物数量") Loop ReDim map(num, num) showMap getRndMap seed Command1.Enabled = True End Sub Private Sub Command3_Click() num = InputBox("请输入大小(1~200)") Do While 1 > num Or num > 200 MsgBox "输入有误 数字限制在1~" & 200 num = InputBox("请输入大小(1~200)") Loop seed = num * num * 0.3 xd = (Form1.ScaleWidth - bound * 2) / num yd = (Form1.ScaleHeight - bound * 2) / num ReDim map(num, num) showMap getRndMap seed Command1.Enabled = True End Sub Private Sub Command4_Click() ReDim map(num, num) getRndMap seed Command1.Enabled = True End Sub Private Sub Command5_Click() Form2.Show End Sub Private Sub Command6_Click() ReDim map(num, num) Cls showMap Command1.Enabled = True End Sub Private Sub custom_Click() If custom.Tag = 0 Then custom.Caption = "停用自订障碍" custom.Tag = 1 Else custom.Caption = "启用自订障碍" custom.Tag = 0 End If End Sub Private Sub Form_Activate() initNum showMap getRndMap seed End Sub Sub initNum() seed = 20 num = 10 xd = (Form1.ScaleWidth - bound * 2) / num yd = (Form1.ScaleHeight - bound * 2) / num ReDim map(num, num) End Sub Sub showMap() For cnt = 0 To num Line (bound, bound + yd * cnt)-(bound + xd * num, bound + yd * cnt) Line (bound + xd * cnt, bound)-(bound + xd * cnt, bound + yd * num) Next End Sub Sub showObj(ByVal yoffset As Integer, ByVal xoffset As Integer, ByVal rgb_ As Long) '显示物件 offset起始值0 Line (bound + xd * xoffset, bound + yd * yoffset)- _ (bound + xd * (xoffset + 1), bound + yd * (yoffset + 1)), rgb_, BF Line (bound + xd * xoffset, bound + yd * yoffset)- _ (bound + xd * (xoffset + 1), bound + yd * (yoffset + 1)), RGB(0, 0, 0), B End Sub Function isWall(ByVal localSet As Long, ByVal nextSet As String) As Boolean y = localSet \ num x = localSet Mod num Select Case nextSet Case "r" 'right If x = num - 1 Then isWall = True: Exit Function If map(y, x + 1).wall = 1 Or map(y, x + 1).route = 1 Then isWall = True: Exit Function Case "l" 'left If x = 0 Then isWall = True: Exit Function If map(y, x - 1).wall = 1 Or map(y, x - 1).route = 1 Then isWall = True: Exit Function Case "t" 'top If y = 0 Then isWall = True: Exit Function If map(y - 1, x).wall = 1 Or map(y - 1, x).route = 1 Then isWall = True: Exit Function Case "b" 'bottom If y = num - 1 Then isWall = True: Exit Function If map(y + 1, x).wall = 1 Or map(y + 1, x).route = 1 Then isWall = True: Exit Function End Select End Function Sub getRndMap(ByVal seedNum As Long) Randomize Cls totalN = num * num ReDim numArr(totalN - 1) As Long ReDim buff(seedNum) As Long For i = LBound(numArr) To UBound(numArr) numArr(i) = i Next For j = 0 To seedNum - 1 totalN = totalN - 1 tmpRnd = Int(Rnd * totalN + 1) buff(j) = numArr(tmpRnd) numArr(tmpRnd) = numArr(totalN) Next For k = LBound(buff) To UBound(buff) - 1 map(buff(k) \ num, buff(k) Mod num).wall = 1 showObj buff(k) \ num, buff(k) Mod num, RGB(0, 0, 255) Next showMap End Sub Sub ans() Dim top As Long Dim ptr As Long tmp = num * num ReDim stack(tmp) As Long top = 0 ptr = 0 map(0, 0).route = 1 showObj 0, 0, RGB(0, 255, 100) Do While ptr <> num * num - 1 If Not isWall(ptr, "r") Then showObj (ptr \ num), (ptr Mod num), RGB(0, 255, 100) map(ptr \ num, ptr Mod num).route = 1 stack(top) = ptr top = top + 1 ptr = ptr + 1 ElseIf Not isWall(ptr, "b") Then showObj (ptr \ num), (ptr Mod num), RGB(0, 255, 100) map(ptr \ num, ptr Mod num).route = 1 stack(top) = ptr top = top + 1 ptr = ptr + num ElseIf Not isWall(ptr, "l") Then showObj (ptr \ num), (ptr Mod num), RGB(0, 255, 100) map(ptr \ num, ptr Mod num).route = 1 stack(top) = ptr top = top + 1 ptr = ptr - 1 ElseIf Not isWall(ptr, "t") Then showObj (ptr \ num), (ptr Mod num), RGB(0, 255, 100) map(ptr \ num, ptr Mod num).route = 1 stack(top) = ptr top = top + 1 ptr = ptr - num ElseIf ptr = 0 Then '四面都是墙时检查是否无解 MsgBox "无解": GoTo EXIT_LABEL Else '走到死路 使用backtracking showObj (ptr \ num), (ptr Mod num), Form1.BackColor map(ptr \ num, ptr Mod num).route = 1 top = top - 1 ptr = stack(top) map(ptr \ num, ptr Mod num).route = 0 End If Loop showObj num - 1, num - 1, RGB(0, 255, 100) MsgBox "Find it" EXIT_LABEL: ReDim stack(tmp) ReDim map(num, num) End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) If (x > bound And x < Form1.ScaleWidth - bound) And (y > bound And y < Form1.ScaleHeight - bound) And custom.Tag = 1 Then If map((y - bound) \ yd, (x - bound) \ xd).wall = 0 Then map((y - bound) \ yd, (x - bound) \ xd).wall = 1 showObj (y - bound) \ yd, (x - bound) \ xd, RGB(0, 0, 255) Else map((y - bound) \ yd, (x - bound) \ xd).wall = 0 showObj (y - bound) \ yd, (x - bound) \ xd, Form1.BackColor End If End If End Sub Module1.bas Type Obj route As Integer wall As Integer End Type --

※ 发信站: 批踢踢实业坊(ptt.cc) ◆ From: 123.240.28.247