Attribute VB_Name = "ModPathFind" Option Explicit Public Grid(0 To 100, 0 To 100) As Integer Public ToDo(0 To 100, 0 To 100) As Boolean Public WalkAble(0 To 100, 0 To 100) As Boolean Public GridHeight(0 To 100, 0 To 100) As String Public GridExtra(0 To 100, 0 To 100) As String Public Type TR NewX As Integer NewY As Integer Direction As Integer SpecStatus As String End Type Public TheResult As TR Dim x As Integer Dim y As Integer Function Direct(y, Y1, x, X1) If y = Y1 And X1 > x Then Direct = 2 'Right ElseIf y = Y1 And X1 < x Then Direct = 6 'Left ElseIf x = X1 And Y1 > y Then Direct = 4 'Down ElseIf x = X1 And Y1 < y Then Direct = 0 'Up Else Direct = 0 End If End Function Function Navigate(StartY, StartX, EndX, EndY, index) As String Dim Route As Integer Call ClearGrid 'Clears the Nodes ready to start again Call CreateGrid(StartX, StartY, EndX, EndY, index) 'Creates the grid for the pathfinding If Grid(EndX, EndY) = 0 Then 'Was it able to get to the end point Navigate = "-1" 'Unable to Navigate to Point Exit Function End If Route = FindFirst(StartX, StartY, EndX, EndY) 'Return the position of where they should move to next 'Routes are opposite that of those in FindFirst because this now goes from 'beginning to end, rather than end to beginning If Route = 1 Then TheResult.NewX = StartX TheResult.NewY = StartY + 1 TheResult.Direction = Direct(StartY, StartY + 1, StartX, StartX) WalkAble(StartX, StartY + 1) = False ElseIf Route = 2 Then TheResult.NewX = StartX TheResult.NewY = StartY - 1 TheResult.Direction = Direct(StartY, StartY - 1, StartX, StartX) WalkAble(StartX, StartY - 1) = False ElseIf Route = 3 Then TheResult.NewX = StartX + 1 TheResult.NewY = StartY TheResult.Direction = Direct(StartY, StartY, StartX, StartX + 1) WalkAble(StartX + 1, StartY) = False ElseIf Route = 4 Then TheResult.NewX = StartX - 1 TheResult.NewY = StartY TheResult.Direction = Direct(StartY, StartY, StartX, StartX - 1) WalkAble(StartX - 1, StartY) = False Else Navigate = "-1" End If WalkAble(StartX, StartY) = True ' WalkAble(4, 4) = False ' WalkAble(4, 6) = False ' WalkAble(5, 4) = False ' WalkAble(6, 4) = False ' WalkAble(7, 4) = False ' WalkAble(9, 4) = False ' WalkAble(9, 3) = False ' WalkAble(9, 2) = False ' WalkAble(9, 1) = False ' WalkAble(7, 5) = False ' WalkAble(7, 6) = False ' WalkAble(7, 7) = False ' WalkAble(7, 8) = False ' WalkAble(7, 9) = False ' WalkAble(7, 10) = False ' WalkAble(7, 11) = False ' WalkAble(7, 12) = False '4 9 0 ' Dim h As Integer ' For h = 4 To 9 ' WalkAble(h, 0) = False ' Next h '4 13 4 1 ' Dim g As Integer ' For g = 1 To 13 ' WalkAble(0, g) = False ' Next g ' Dim j As Integer ' For j = 4 To 11 ' WalkAble(j, 14) = False ' Next j ' ' Dim v As Integer ' For v = 1 To 13 ' WalkAble(12, v) = False ' Next v End Function Sub ClearGrid() For x = 0 To 100 For y = 0 To 100 ToDo(x, y) = False Grid(x, y) = False Next Next End Sub Sub CreateGrid(StartX, StartY, EndX, EndY, index) Dim HaveToDo As Boolean ToDo(StartX, StartY) = True Grid(StartX, StartY) = 1 'Only exit if there is a link between the end position and beginning position 'or there are more nodes to be processed; in which case a route was not made Do HaveToDo = False 'Set to False, if a node needs processing it is set to true 'Go though the grid and check to see if there is a node which needs processing For x = 0 To 99 For y = 0 To 99 If ToDo(x, y) = True Then HaveToDo = True 'Check if a node needs processing if yes set HavetoDo to True ToDo(x, y) = False 'Check to see if going up is within array bounds If y - 1 >= 0 Then 'Check if the land is passable, proceed if it is If WalkAble(x, y - 1) = True Then 'Only Place new node if it is smaller than the which is already 'there or if it is 0 in which case it has not been used If Grid(x, y - 1) = 0 Or Grid(x, y) + 1 < Grid(x, y - 1) Then Grid(x, y - 1) = Grid(x, y) + 1 ToDo(x, y - 1) = True End If End If End If 'check to see if going left is within array bounds If x - 1 >= 0 Then 'Check if the land is passable, proceed if it is If WalkAble(x - 1, y) = True Then 'Only Place new node if it is smaller than the which is already 'there or if it is 0 in which case it has not been used If Grid(x - 1, y) = 0 Or Grid(x, y) + 1 < Grid(x - 1, y) Then Grid(x - 1, y) = Grid(x, y) + 1 ToDo(x - 1, y) = True End If End If End If 'check to see if going right is within array bounds If x + 1 < 100 Or Grid(x, y) + 1 < Grid(x + 1, y) Then 'Check if the land is passable, proceed if it is If WalkAble(x + 1, y) = True Then 'Only Place new node if it is smaller than the which is already 'there or if it is 0 in which case it has not been used If Grid(x + 1, y) = 0 Then Grid(x + 1, y) = Grid(x, y) + 1 ToDo(x + 1, y) = True End If End If End If 'Check to see if going down is within array bounds If y + 1 < 100 Or Grid(x, y) + 1 < Grid(x, y + 1) Then 'Check if the land is passable, proceed if it is If WalkAble(x, y + 1) = True Then 'Only Place new node if it is smaller than the which is already 'there or if it is 0 in which case it has not been used If Grid(x, y + 1) = 0 Then Grid(x, y + 1) = Grid(x, y) + 1 ToDo(x, y + 1) = True End If End If End If End If Next Next Loop Until Grid(EndX, EndY) <> 0 Or HaveToDo = False End Sub Function FindFirst(StartX, StartY, EndX, EndY) 'On Error GoTo fuckoff Dim CX As Integer 'Current X Dim CY As Integer 'Current Y Dim CurValue As Integer Dim Choosen As Integer CX = EndX CY = EndY 'Trace the values back from the end to the beginning to get the route taken 'it is not done the other way round because we know a route is made and that 'if it is done from the start the route may end half way through CurValue = Grid(EndX, EndY) Do If CY - 1 >= 0 Then If Grid(CX, CY - 1) < CurValue And Grid(CX, CY - 1) > 0 Then Choosen = 1 CurValue = Grid(CX, CY - 1) End If End If If CY + 1 <= 99 Then If Grid(CX, CY + 1) < CurValue And Grid(CX, CY + 1) > 0 Then Choosen = 2 CurValue = Grid(CX, CY + 1) End If End If If CX - 1 >= 0 Then If Grid(CX - 1, CY) < CurValue And Grid(CX - 1, CY) > 0 Then Choosen = 3 CurValue = Grid(CX - 1, CY) End If End If If CX + 1 <= 99 Then If Grid(CX + 1, CY) < CurValue And Grid(CX + 1, CY) > 0 Then Choosen = 4 CurValue = Grid(CX + 1, CY) End If End If If Choosen = 1 Then CY = CY - 1 ElseIf Choosen = 2 Then CY = CY + 1 ElseIf Choosen = 3 Then CX = CX - 1 ElseIf Choosen = 4 Then CX = CX + 1 End If Loop Until CX = StartX And CY = StartY FindFirst = Choosen 'Return the Choosen Route 'Exit Function 'fuckoff: End Function Sub Blankgrid(index) For x = 0 To 100 For y = 0 To 100 WalkAble(x, y) = True Next Next End Sub