應用所學寫了一隻程式 讓它可以自己產生迷宮 用亂數產生牆 用滑鼠點擊修改牆 清空牆 重新設定牆 等等功能 想問問各位前輩還有沒有可以優化的地方 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