vb+oracle+mapx实现的最短路径查询

左半边

Const INFINITE = 1E+38 \'无限大常数
Const maxNode = 292 \'最大顶点数
Const maxEdge = 440 \'最大边数

Dim fnode1(1 To maxEdge) As Integer \'记录以起点排序的起点集
Dim tnode1(1 To maxEdge) As Integer \'记录以起点排序的终点集
Dim lgth1(1 To maxEdge) As Double \'记录与前两个数组对应的路径长度
Dim roadid1(1 To maxEdge) As Integer \'记录对应的roadid号
Dim fnode2(1 To maxEdge) As Integer \'记录以终点排序的起点集
Dim tnode2(1 To maxEdge) As Integer \'记录以终点排序的终点集
Dim lgth2(1 To maxEdge) As Double \'记录以终点排序时的路径长度值
\'Dim roadid2(1 To maxEdge) As Integer
Dim F_TNode(2, maxNode) As Integer \'total FirstNodes connect to a LastNode，二维
Dim T_FNode(2, maxNode) As Integer \'total LastNodes connect to a FirstNode

Dim path() As Integer
Dim roadid() As Integer

Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset

Dim flagShrstPath As Boolean
Dim lInfo As New Mapxlib.LayerInfo

Private Sub cmdShrstPath_Click()
If flagShrstPath = False Then
flagShrstPath = True
cmdShrstPath.Caption = "路径分析（开）"
End If

If flagShrstPath = True Then
cmdShrstPath.Enabled = False
Debug.Print "The shortest length is: " + CStr(shortpath(1, 291))

\'////在地图上显示最短路径
Dim lyrs As New Mapxlib.Layers
Dim lyrFindLayer As Mapxlib.Layer
\'Dim ftrs As MapXLib.Features
Dim ftr As Mapxlib.Feature
\'Dim dsets As MapXLib.DataSets
\'Dim dset As MapXLib.Dataset
\'Dim rvs As MapXLib.Rowvalues
\'Dim rv As MapXLib.Rowvalue
Dim slt As Mapxlib.Selection
Dim foundFeature As Mapxlib.FindFeature
Set lyrFindLayer = Map.Layers.Add(lInfo)
\'ftr=lyrFindLayer.f
Dim roadid As Integer
For Each roadid In path()
If ftr.FeatureKey = roadid Then
End If
End Sub


Private Sub Form_Load()
flagShrstPath = False

\'Dim lInfo As New MapXLib.LayerInfo

lInfo.Type = miLayerInfoTypeServer \'来自数据库服务器

\'定义连接字符串
Dim connectStr As String
connectStr = "SRVR=gis;UID=crmgisWD=mapinfo"

\'添加LayerInfo参数
lInfo.AddParameter "connectstring", connectStr
lInfo.AddParameter "name", "try"
lInfo.AddParameter "toolkit", "ORAINET"
lInfo.AddParameter "cache", "off"
lInfo.AddParameter "mbrsearch", "on"
lInfo.AddParameter "query", "select * from Road"
lInfo.AddParameter "AutoCreateDataset", 1
\'至此，完成数据库的连接了，开发者可以进行相应的数据调用了

Map.Layers.Add lInfo, 1

End Sub

Private Sub Initialize()
\'//////////连接数据库，读入有关数据
\'On Error GoTo procerror
conn.Open "dsn=crm;uid=crmgisWD=mapinfo;"


\'////////////////////Topo关系数组的初始化/

Dim i As Integer
Dim j As Integer

\'//////////初始化fnode1,tnode1,lgth1Dim sqlStr1 As String
sqlStr1 = "select firstnode,lastnode,length, roadid from road order by firstnode"
rs.Open sqlStr1, conn

rs.MoveFirst
For i = 1 To maxEdge
fnode1(i) = CInt(rs!FIRSTNODE)
tnode1(i) = CInt(rs!LASTNODE)
lgth1(i) = CDbl(rs!Length)
roadid1(i) = CInt(rs!roadid)

If rs.EOF = False Then
rs.MoveNext
End If
Next i
rs.Close

\'//////////初始化fnode2,tnode2,lgth2
Dim sqlStr2 As String
sqlStr2 = "select firstnode,lastnode,length,roadid from road order by lastnode"
rs.Open sqlStr2, conn

rs.MoveFirst
For i = 1 To maxEdge
fnode2(i) = CInt(rs!FIRSTNODE)
tnode2(i) = CInt(rs!LASTNODE)
lgth2(i) = CDbl(rs!Length)
\'roadid2(i) = CInt(rs!roadid)

If rs.EOF = False Then
rs.MoveNext
End If
Next i
rs.Close

conn.Close

\'//////////////找出某个起点与其相连的终点的个数
Dim m As Integer
Dim flag As Boolean \'设置一个旗标看某点号是否重复出现

For j = 1 To 2
For m = 1 To maxNode
T_FNode(j, m) = -1
F_TNode(j, m) = -1
Next m
Next j

For j = 1 To maxNode
flag = False
For m = 1 To maxEdge
If j = fnode1(m) And flag = False Then
T_FNode(1, j) = m \'表示j点拥有终点，并且该点在fnode1()中的位置为m
T_FNode(2, j) = 1
flag = True
ElseIf j = fnode1(m) And flag = True Then
T_FNode(1, j) = m
T_FNode(2, j) = T_FNode(2, j) + 1
End If
Next m
Next j

\'///////////////找出与某个终点相连的起点的个数
For j = 1 To maxNode
flag = False
For m = 1 To maxEdge
If j = tnode2(m) And flag = False Then
F_TNode(1, j) = m
F_TNode(2, j) = 1
flag = True
ElseIf j = tnode2(m) And flag = True Then
F_TNode(1, j) = m
F_TNode(2, j) = F_TNode(2, j) + 1
End If
Next m
Next j

\'procerror:
\'MsgBox "数据库连接错误！"
End Sub



Public Function shortpath(startno As Integer, endno As Integer) As Double \'以开始点，结束点为参数。

Dim result() As Double
Dim result1 As Integer \'定义结果点
Dim s1 As Double
Dim Stpath As Double
Dim min As Double
Dim ll As Integer \'记录开始点

Dim ii As Integer
Dim i As Integer
Dim j As Integer
Dim aa As Integer
Dim p As Integer
Dim q As Integer
Dim k As Integer


Dim visited() As Boolean \'标记已经检查过的点
Dim inResult() As Boolean \'标记已经作结果点用过的点
Dim resultLength() As Double \'从起点算起的最短路程

Dim no() As Integer
Dim nopoint As Integer

ReDim visited(1 To maxNode) As Boolean
ReDim inResult(1 To maxNode) As Boolean

ReDim resultLength(1 To maxNode) As Double
ReDim result(1 To 2, 1 To maxNode) As Double \'定义结果，其中result(1,maxNode)为结果点，result(2,maxNode)为结果长度。

Call Initialize

For k = 1 To maxNode \' maxNode为网中最大的节点数。
visited(k) = False \'标记已经查过的点。
inResult(k) = False \'标记已经作结果点用过的点
resultLength(k) = 1E+38 \'假设从起点到任一点的距离都为无穷大
Next k

ll = startno \'设置开始点。
visited(ll) = True \'标记开始点为真。即已经作结果点用过。

j = 0
For aa = 1 To maxNode

\'先从与开始点相连的终点寻找
For i = 1 To T_FNode(2, ll) \'以与ll点相连的终点的个数循环
result1 = tnode1(T_FNode(1, ll) - i + 1) \'找出与LL点相连的终点的点号
s1 = lgth1(T_FNode(1, ll) - i + 1) + result(2, ll) \'找出长度并求和

If visited(result1) = True Then GoTo 200 \'如果已经被查过进行下一个

If inResult(result1) = True Then \'如果已经作为结果点判断哪一个长
If resultLength(result1) >= s1 Then \'如果这一点到起点的长度比现在的路线长，替代
resultLength(result1) = s1
result(1, result1) = ll \'设置到这点的最短路径的前一点为LL点（精华部分）
result(2, result1) = s1 \'设置到这点的最短路径长度
GoTo 200
Else
GoTo 200
End If
End If

\'如果上面的条件都不符合则进行下面的语句
inResult(result1) = True
resultLength(result1) = s1
result(1, result1) = ll
result(2, result1) = s1

\'每找到一个点加一，为了下面的判断
j = j + 1

ReDim Preserve no(1 To j) As Integer \'重新定义数组并使其值为当前的点号

no(j) = result1

200 Next i

\'再从与开始点相连的起点寻找，与上面一样不再标注
For p = 1 To F_TNode(2, ll)
result1 = fnode2(F_TNode(1, ll) - p + 1)
s1 = lgth2(F_TNode(1, ll) - p + 1) + result(2, ll)
If visited(result1) = True Then GoTo 300

If inResult(result1) = True Then
If resultLength(result1) >= s1 Then
resultLength(result1) = s1
result(1, result1) = ll
result(2, result1) = s1
GoTo 300
Else
GoTo 300
End If
End If

inResult(result1) = True
resultLength(result1) = s1
result(1, result1) = ll
result(2, result1) = s1

j = j + 1

ReDim Preserve no(1 To j) As Integer
no(j) = result1
300 Next p

\'设置最小为无穷大，最短路径点为空
min = 1E+38
minpoint = Null

\'（优化部分）
\'找出已经查过点中长度最短的点
For q = aa To j
If min > resultLength(no(q)) Then
ii = q
min = resultLength(no(q))
minpoint = no(q)
End If
Next q

\'如果没有结果，即起点与终点没有通路退出程序
If min = 1E+38 Then Exit Function

\'（重点优化）将两点互换，减少循环。
no(ii) = no(aa)
no(aa) = minpoint \'将路径最短的点放到no()中靠前一个位置

\'ReDim Preserve path(1 To aa) As Integer
\'path(aa) = minpoint

\'标记已经作为结果点判断过
visited(minpoint) = True
\'inResult(minpoint) = True
ll = minpoint \'下次从找到的路径最短的点出发


\'判断结果点是否等于终点，如果等于则已经找到最短路径
If minpoint = endno Then Exit For
Next aa

Dim z As Integer
Dim tempPoint As Integer

z = 2
tempPoint = result(1, endno)
ReDim Preserve path(1 To z) As Integer \'path()前两个元素保存终点和终点的前一点，path()数组是从起点到终点路径点的反向顺序
path(1) = endno
path(2) = result(1, endno)
Do While tempPoint <> startno
tempPoint = result(1, tempPoint) \'找出从起点到当前点的最短路径的前一点
z = z + 1
ReDim Preserve path(1 To z) As Integer
path(z) = tempPoint
Loop


ReDim roadid(z - 1) As Integer \'保存结果路径的roadid
Dim h As Integer
For h = z To 2 Step -1
For i = 1 To maxEdge
If path(h) = fnode1(i) And path(h - 1) = tnode1(i) Then
roadid(h - 1) = roadid1(i)
Exit For
ElseIf path(h) = tnode1(i) And path(h - 1) = fnode1(i) Then
roadid(h - 1) = roadid1(i)
Exit For
End If
Next i
Next h
For k = z - 1 To 1 Step -1
Debug.Print "RoadID: " + CStr(roadid(k)) \'输出路径，注意path()是反向的，即是从终点到起点的。
Next k


shortpath = result(2, endno) \'返回最短路径长度
End Function