form1.frm

用vc开发的A*寻路算法的dll,可以在其他语言调用

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4470
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6390
   LinkTopic       =   "Form1"
   ScaleHeight     =   4470
   ScaleWidth      =   6390
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   300
      Left            =   5280
      TabIndex        =   1
      Top             =   4680
      Width           =   975
   End
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      Height          =   4455
      Left            =   0
      ScaleHeight     =   4395
      ScaleWidth      =   6315
      TabIndex        =   0
      Top             =   0
      Width           =   6375
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'寻找最短路径，数组中设为"o"的地方为墙壁。设为" "的地方为空地

Option Explicit

Private Declare Function SetMap Lib "A_Star.dll" (inputMaps As Byte, ByVal inputRows As Long, ByVal inputCols As Long) As Long
Private Declare Function FindWay Lib "A_Star.dll" (ByVal fromPoint As Long, ByVal toPoint As Long, outway As Long, outcount As Long) As Long

Private Const cols = 30
Private Const rows = 21

Dim map(0 To cols * rows - 1) As Byte

Dim cellWidth As Long
Dim cellHeight As Long


Private Sub Form_Load()
Dim i As Long, j As Long
Dim outway() As Long
Dim outcount As Long
ReDim outway(100)
    cellWidth = Picture1.ScaleWidth / cols
    cellHeight = Picture1.ScaleHeight / rows
    For i = 0 To rows - 1
        For j = 0 To cols - 1
            map(i * cols + j) = Asc(" ")
        Next j
    Next i
    Call SetMap(map(0), rows, cols)
    'Call FindWay(ByVal 0, ByVal 5 * cols + 5, outway(0), outcount)
    'MsgBox outcount
    DrawMap
End Sub


Private Sub DrawMap()
Dim color As Long
Dim i As Long, j As Long
    For i = 0 To rows - 1
        For j = 0 To cols - 1
            If map(i * cols + j) = Asc(" ") Then
                color = &H888888
            Else
                color = &H999999
            End If
            Picture1.Line (j * cellWidth, i * cellHeight)-((j + 1) * cellWidth, (i + 1) * cellHeight), color, BF
        Next j
    Next i
    For i = 0 To rows - 1
        For j = 0 To cols - 1
            If map(i * cols + j) = Asc(" ") Then
                color = &H777777
            End If
            Picture1.Line (j * cellWidth, i * cellHeight)-((j + 1) * cellWidth, (i + 1) * cellHeight), color, B
        Next j
    Next i
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call Picture1_MouseMove(Button, Shift, X, Y)
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long, j As Long
Dim selectedCol As Long, selectedRow As Long
    If Button = 1 Or Button = 2 Then
        For i = 0 To rows - 1
            For j = 0 To cols - 1
                If X < (j + 1) * cellWidth And X > j * cellWidth Then
                    If Y < (i + 1) * cellHeight And Y > i * cellHeight Then
                        selectedCol = j
                        selectedRow = i
                    End If
                End If
            Next j
        Next i
    End If
    If map(selectedRow * cols + selectedCol) = Asc("e") Or map(selectedRow * cols + selectedCol) = Asc("s") Then
        Exit Sub
    End If
    If Button = 2 Then
        map(selectedRow * cols + selectedCol) = Asc(" ")
        Call SetMap(map(0), rows, cols)
        DrawMap
    ElseIf Button = 1 Then
        map(selectedRow * cols + selectedCol) = Asc("o")
        Call SetMap(map(0), rows, cols)
        DoEvents
        DrawMap
    End If
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim outway(1000) As Long
Dim outcount As Long
Dim i As Long, j As Long
Dim c As Long, r As Long
Dim color As Long

    If FindWay(ByVal 0 * 0, ByVal cols * rows - 1, outway(0), outcount) <> 0 Then
        For i = 0 To outcount - 1
            r = outway(i) \ cols
            c = outway(i) Mod cols
            color = &H666666
            Picture1.Line (c * cellWidth, r * cellHeight)-((c + 1) * cellWidth, (r + 1) * cellHeight), color, BF
        Next i
    Else
        Debug.Print "没有找到"
    End If
End Sub