|
If i = j Then
flagMatrix(i, j) = True '对角元素
Else
flagMatrix(i, j) = False
End If
Next j
Next i
For i = 1 To nNode
For j = 1 To nLineNode
If (LineNode(1, j) = NoNode(i)) Then
For k = 1 To nNode
If (NoNode(k) =
LineNode(2, j)) Then
temp = k
Exit For
End If
Next k
flagMatrix(i, temp) = True
'无向图,对称矩阵
flagMatrix(temp, i) = True
ElseIf (NoNode(i) = LineNode(2, j)) Then
For q = 1 To nNode
If (NoNode(q) =
LineNode(1, j)) Then
temp = q
Exit For
End If
Next q
flagMatrix(i, temp) = True
flagMatrix(temp, i) = True
End If
Next j
Next i
maxlen = 1E+38 'distmatrix邻接距离矩阵
For i = 1 To nNode
For j = 1 To nNode
If flagMatrix(i, j) = True Then
distmatrix(i, j) = 111.199 *
Sqr((LatNode(i) - LatNode(j)) ^ 2 +
((LonNode(i) - LonNode(j)) * Cos((LatNode(i) + LatNode(j)) * 0.00872665)) ^ 2)
Else '节点不邻接
distmatrix(i, j) = maxlen
End If
Next j
Next i
End Sub
Private Sub selectstartendnode_Click()
MsgBox ("请用工具栏里的点选择工具（第5个按钮）指定起点、终点!")
End Sub
Private Sub showstartendnodeinfo_Click()
Dim i As Integer, ftr As MapXLib.Feature
For i = 1 To Map1.
Layers(nodelayerindex).Selection.Count
'选择集中的每个feature
For Each ftr In Map1.
Layers(nodelayerindex).AllFeatures
'对应图层中的每个feature
If Map1.Layers(nodelayerindex).
Selection(i).FeatureID = ftr.FeatureID Then
If i = 1 Then
StartNo = ftr.FeatureID
'指定的起点
txtfid.Text = StartNo
End If
If i = Map1.Layers
(nodelayerindex).Selection.Count Then
EndNo = ftr.FeatureID
'指定的终点
txttid.Text = EndNo
End If
For j = 1 To Map1.
DataSets(nodelayerindex).Fields.Count
List1.AddItem Map1.DataSets(nodelayerindex).Fields(j).Name & ":" & Map1.DataSets(nodelayerindex).
Value(ftr.FeatureID, j)
Next j
List1.AddItem "ID:" & Map1.Layers(nodelayerindex).Selection(i).FeatureID
Exit For ' featureID是唯一的
End If
Next
Next i
End Sub
Private Sub Map1_ToolUsed(ByVal ToolNum As Integer, ByVal X1 As Double, ByVal Y1 As Double, ByVal X2 As Double, ByVal Y2 As Double, ByVal Distance As Double, ByVal Shift As Boolean, ByVal Ctrl As Boolean, EnableDefault As Boolean)
Dim curfeatures As MapXLib.Features
Dim ftr As MapXLib.Feature
Dim searchlayer As MapXLib.Layer
Dim pt As New MapXLib.Point
Select Case ToolNum
Case select_point
pt.Set X1, Y1
Set searchlayer =
Map1.Layers(nodelayerindex)
Set curfeatures =
searchlayer.SearchAtPoint(pt)
Map1.Layers(nodelayerindex).Selection.Add curfeatures
Set pt = Nothing
Set curfeatures = Nothing
Set obj = Nothing
Case Else
End Select
ptcount = Map1.Layers(nodelayerindex).
Selection.Count
If ptcount = 2 Then MsgBox ("已经指定起点、终点了,请进行最短路径查询!")
End Sub
Private Sub searchshortestpath_Click()
'查询最短路径
Dim i As Integer
ReDim yjdb(1 To nNode) As Boolean,
ReDim distvector(1 To nNode) As Double
tempstartno = StartNo: tempendno = EndNo
For i = 1 To nNode
'初始化永久标号标志yjdb()
If i = tempstartno Then
yjdb(i) = True '让起点获得永久标号
Else
yjdb(i) = False
End If
Next i
distvector(tempstartno) = 0 '起点距离赋0
For i = 1 To nNode
'初始化每个节点与起点的距离
If flagMatrix(tempstartno, i) = True Then
distvector(i) = distmatrix(tempstartno, i) Else
distvector(i) = 1E+38
End If
Next i
isall = isallyjdb
Do While (isall = False) '对应算法步骤4
Call minnode '算法步骤2
Call gbdb '算法步骤3
isall = isallyjdb
If isall = True Then '节点都获得永久标号
shortestdist = distvector(EndNo)
txtresultlength.Text = shortestdist
End If
Loop
Call plotroutin '画出查询到的最短路径
MsgBox ("查询完毕!")
End Sub
Public Function isallyjdb() As Boolean
'判断是否所有节点都获得永久标号
Dim tempisallyjdb As Boolean
tempisallyjdb = True
For i = 1 To nNode
If yjdb(i) = False Then
tempisallyjdb = False
Exit For
End If
Next i
isallyjdb = tempisallyjdb
End Function
Public Function minnode()
'寻找具有最小临时标号的节点
Dim mindist As Double, minnodeno As Integer, i As Integer
mindist = 1E+38
For i = 1 To nNode
If yjdb(i) = False Then
If distvector(i) < mindist Then
mindist = distvector(i)
minnodeno = i
End If
End If
Next i
oldtempstartno = tempstartno
tempstartno = minnodeno
distvector(tempstartno) = mindist
'新获得永久标号的节点
yjdb(tempstartno) = True
End Function
Public Function gbdb()
'更新与刚获得永久标号节点相连的
'各节点的临时标号
Dim i As Integer
For i = 1 To nNode
If (flagMatrix(tempstartno, i) = True And yjdb(i) = False) Then
If distvector(i) > distvector (temp
startno) +distmatrix(tempstartno, i) Then
distvector(i) = distvector(temp
startno) + distmatrix(tempstartno, i)
End If
End If
Next i
End Function
Public Function plotroutin()
'进行逆推,画出最短路径
Dim szdcount As Integer
Dim tem1 As Boolean, tem2 As Boolean, bj1 As Integer, bj2 As Integer
szdcount = 1
ReDim Preserve szdno(szdcount) As Integer
szdno(1) = EndNo
Do While (tempendno <> StartNo)
'从终点逆推到起点时结束
For i = 1 To nNode
If flagMatrix(tempendno, i) = True Then
If (distvector(tempendno) - distvector(i) = distmatrix(tempendno, i) Or
Abs(distvector(tempendno) - distvector(i) –
distmatrix(tempendno, i)) < 0.001) Then
szdcount = szdcount + 1
ReDim Preserve szdno(szdcount) As Integer
szdno(szdcount) = i
oldtempendno = tempendno
tempendno = i
End If
End If
Next i
Loop
Dim ftr As MapXLib.Feature
For i = 1 To szdcount
For Each ftr In
Map1.Layers(nodelayerindex).AllFeatures
If ftr.FeatureID = szdno(i) Then
Map1.Layers(1).Selection.Add ftr
End If
Next
Next i
For Each ftr In
Map1.Layers(linelayerindex).AllFeatures
tem1 = False: tem2 = False
For i = 1 To szdcount
For j = 1 To nNode
If LineNode(1, ftr.FeatureID) = NoNode(j) Then
bj1 = j
Exit For
End If
Next j
If bj1 = szdno(i) Then
'针对标注,ID不同的情况
tem1 = True
End If
For k = 1 To nNode
If LineNode(2, ftr.FeatureID) = NoNode(k) Then
bj2 = k
Exit For
End If
Next k
If bj2 = szdno(i) Then
tem2 = True
End If
If tem1 = True And tem2 = True Then
Map1.Layers(linelayerindex).Selection.Add ftr
Exit For
End If
Next i
Next
End Function
Private Sub Toolbar1_ButtonClick(ByVal
Button As MSComctlLib.Button)
Select Case Button.Key
Case "zoomin" '放大
Map1.CurrentTool = miZoomInTool
Case "zoomout" '缩小
Map1.CurrentTool = miZoomOutTool
Case "global" '全图
Map1.Bounds = Map1.Layers.Bounds
Case "pan" '漫游
Map1.CurrentTool = miPanTool
Case "arrow" '点选择
Map1.CurrentTool = select_point
End Select
End Sub
程序运行结果如图５所示。
图5 程序运行结果
四、结语
本文通过MapX控件将地图功能嵌入应用程序，实现地图可视化。程序通过Dijkstra算法，实现在中国主干公路网中指定的起点、终点间的最短路径查询。程序能够进行正确查询，运行速率较为满意。
|
