📄 frmfindshortpath.frm
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmFindShortPath
Caption = "Find short path"
ClientHeight = 6795
ClientLeft = 60
ClientTop = 345
ClientWidth = 5070
LinkTopic = "Form2"
MaxButton = 0 'False
ScaleHeight = 6795
ScaleWidth = 5070
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton cmdFindShortPath
Caption = "Find Short Path"
Height = 345
Left = 1350
TabIndex = 4
Top = 2970
Width = 1650
End
Begin MSFlexGridLib.MSFlexGrid flxS
Height = 675
Left = 45
TabIndex = 2
Top = 3375
Width = 4980
_ExtentX = 8784
_ExtentY = 1191
_Version = 393216
Rows = 1
Cols = 1
FixedRows = 0
FixedCols = 0
End
Begin VB.CommandButton cmdCalcData
Caption = "Calculate Data"
Height = 420
Left = 150
TabIndex = 1
Top = 75
Width = 1470
End
Begin MSFlexGridLib.MSFlexGrid flxMap
Height = 2355
Left = 45
TabIndex = 0
Top = 555
Width = 4980
_ExtentX = 8784
_ExtentY = 4154
_Version = 393216
Rows = 1
Cols = 1
FixedRows = 0
FixedCols = 0
End
Begin MSFlexGridLib.MSFlexGrid flxDist
Height = 675
Left = 45
TabIndex = 5
Top = 4425
Width = 4980
_ExtentX = 8784
_ExtentY = 1191
_Version = 393216
Rows = 1
Cols = 1
FixedRows = 0
FixedCols = 0
End
Begin MSFlexGridLib.MSFlexGrid flxPath
Height = 675
Left = 45
TabIndex = 7
Top = 5505
Width = 4980
_ExtentX = 8784
_ExtentY = 1191
_Version = 393216
Rows = 1
Cols = 1
FixedRows = 0
FixedCols = 0
End
Begin VB.Label Label4
Caption = "You should click on any two objects before finding the path"
Height = 420
Left = 1995
TabIndex = 12
Top = 60
Width = 2775
End
Begin VB.Label lblTheDistance
Alignment = 2 'Center
Caption = "lblTheDistance"
Height = 255
Left = 135
TabIndex = 11
Top = 6555
Width = 4815
End
Begin VB.Label lblResult
Alignment = 2 'Center
Caption = "lblResult"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 177
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 45
TabIndex = 10
Top = 6225
Width = 4950
End
Begin VB.Label lblFromTo
Alignment = 2 'Center
Caption = "lblFromTo"
Height = 195
Left = 3060
TabIndex = 9
Top = 3060
Width = 1905
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "path:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 177
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 195
TabIndex = 8
Top = 5175
Width = 600
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "distance:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 177
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 180
TabIndex = 6
Top = 4095
Width = 1065
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "s:"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 177
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 180
TabIndex = 3
Top = 3045
Width = 225
End
End
Attribute VB_Name = "frmFindShortPath"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' ==========================================
' Dijkstra's algorithm to find Shortest Path
' ==========================================
'
' E.W. Dijkstra is a Dutch professor in Computer
' Science, who did a lot of research in graphs.
'
' Dijkstra's algorithm is of use when working with
' directional graphs. It constructs the shortest path
' between a starting-node and a goal-node.
' It is assumed that every link between two nodes
' has a certain cost, and this algorithm finds the
' path between the two given nodes with the lowest cost.
'
' The idea of this VB project was to show the
' work of this algorithm in a visual way.
'
' Screen-shot: dijkstra.gif
'
'
' Visit my Homepage:
' http://www.geocities.com/emu8086/vb/
'
'
' Last Update: Saturday, July 20, 2002
'
'
' Copyright 2002 Alexander Popov Emulation Soft.
' All rights reserved.
' http://www.geocities.com/emu8086/
Option Explicit
Dim sFrom As String
Dim sTo As String
Const INF = 32767 ' infinity, so big so far, it should end somewhere anyway :)
Dim sRESULT(1 To 100) As String
Dim iRES_SIZE As Integer
Private Sub cmdCalcData_Click()
Dim i As Integer
Dim j As Integer
Dim toIndex As Integer
flxMap.Rows = Form1.theBlockCollection.Count + 1
flxMap.Cols = Form1.theBlockCollection.Count + 1
If Form1.theBlockCollection.Count > 0 Then
flxMap.FixedRows = 1
flxMap.FixedCols = 1
End If
For i = 0 To flxMap.Cols - 1
flxMap.ColWidth(i) = 530
Next i
For i = 1 To Form1.theBlockCollection.Count
flxMap.Row = i
flxMap.Col = 0
flxMap.Text = Form1.theBlockCollection(i).sCaption
flxMap.Row = 0
flxMap.Col = i
flxMap.Text = Form1.theBlockCollection(i).sCaption
flxMap.Row = i
For j = 1 To flxMap.Cols - 1
flxMap.TextMatrix(i, j) = "0"
flxMap.Col = j
flxMap.CellForeColor = vbBlack
flxMap.CellFontBold = False
Next j
For j = 1 To Form1.theLineCollection.Count
If Form1.theLineCollection(j).sFrom = Form1.theBlockCollection(i).TagID Then
toIndex = Form1.theBlockCollection.getIndexFromTag(Form1.theLineCollection(j).sTo)
flxMap.Col = toIndex
flxMap.Text = Form1.theLineCollection(j).sCaption
If (flxMap.Text = "") Then flxMap.Text = "1" ' don't allow empty!!!! (for lines with no caption)
flxMap.CellForeColor = vbRed
flxMap.CellFontBold = True
End If
Next j
Next i
End Sub
Private Sub prepareFSP()
Dim i As Integer
flxS.Rows = 2
flxDist.Rows = 2
flxPath.Rows = 2
flxS.Cols = flxMap.Cols
flxDist.Cols = flxMap.Cols
flxPath.Cols = flxMap.Cols
If flxS.Cols > 1 Then
flxS.FixedRows = 1
flxDist.FixedRows = 1
flxPath.FixedRows = 1
flxS.FixedCols = 1
flxDist.FixedCols = 1
flxPath.FixedCols = 1
End If
For i = 0 To flxS.Cols - 1
flxS.ColWidth(i) = flxMap.ColWidth(i)
flxDist.ColWidth(i) = flxMap.ColWidth(i)
flxPath.ColWidth(i) = flxMap.ColWidth(i)
flxS.TextMatrix(0, i) = flxMap.TextMatrix(0, i)
flxDist.TextMatrix(0, i) = flxMap.TextMatrix(0, i)
flxPath.TextMatrix(0, i) = flxMap.TextMatrix(0, i)
Next i
For i = 1 To flxS.Cols - 1
flxS.TextMatrix(1, i) = "False"
flxS.Row = 1
flxS.Col = i
flxS.CellForeColor = vbBlack
flxS.CellFontBold = False
flxDist.TextMatrix(1, i) = "INF"
flxPath.TextMatrix(1, i) = "0"
Next i
End Sub
Private Sub cmdFindShortPath_Click()
prepareFSP
Dim src As Integer
Dim dest As Integer
src = getIndexOfTabName(sFrom)
dest = getIndexOfTabName(sTo)
If (src = -1) Or (dest = -1) Then
MsgBox "something wrong!!!"
Exit Sub
End If
' working with first row always!
flxS.Row = 1
flxDist.Row = 1
flxPath.Row = 1
Dim MAX As Integer
MAX = flxMap.Cols
'''' copy code from C
Dim current As Integer ' /* current intersection */
Dim dist_fc As Integer ' /* dist from first intersection to current */
Dim i As Integer
Dim min As Integer
Dim do_search As Boolean
do_search = True
' /* reset arrays */
' (done already)
current = src
dist_fc = 0
'/* first intersection is set True */
flxS.TextMatrix(1, current) = "True"
flxS.Row = 1
flxS.Col = current
flxS.CellForeColor = vbRed
flxS.CellFontBold = True
flxDist.TextMatrix(1, current) = 0
Do While do_search
'/* update array dist according to all
'intersections that current intersection
'can get to */
For i = 1 To MAX - 1
If ((myVl(flxMap.TextMatrix(current, i)) <> 0) And _
(myVl(flxDist.TextMatrix(1, i)) > myVl(flxMap.TextMatrix(current, i)) + dist_fc)) Then
flxDist.TextMatrix(1, i) = myVl(flxMap.TextMatrix(current, i) + dist_fc)
flxPath.TextMatrix(1, i) = current
End If
Next i
'/* find intersection with lowest value, and
'that is not checked in s[] yet */
min = INF
For i = 1 To MAX - 1
If ((myVl(flxDist.TextMatrix(1, i)) < min) And (flxS.TextMatrix(1, i) = "False")) Then
min = myVl(flxDist.TextMatrix(1, i))
current = i
dist_fc = myVl(flxDist.TextMatrix(1, i))
End If
Next i
flxS.TextMatrix(1, current) = "True"
flxS.Row = 1
flxS.Col = current
flxS.CellForeColor = vbRed
flxS.CellFontBold = True
'/* stop searching if all intersections processed */
If (min = INF) Then
do_search = False
End If
Loop
'/* print out the path */
iRES_SIZE = 0
makeAllLines_Black
lblResult.Caption = "The path is: "
current = dest
Do While current <> src
If (flxPath.TextMatrix(1, current) = "0") Then
lblResult.Caption = "NO PATH FROM " & flxMap.TextMatrix(0, src) & " TO " & flxMap.TextMatrix(0, dest) & "!"
lblTheDistance.Caption = ""
Exit Sub
End If
lblResult.Caption = lblResult.Caption & flxMap.TextMatrix(0, current)
addTO_RESULT (current)
lblResult.Caption = lblResult.Caption & " <- "
current = myVl(flxPath.TextMatrix(1, current))
Loop
lblResult.Caption = lblResult.Caption & flxMap.TextMatrix(0, src)
addTO_RESULT (src)
' /* print out the distance */
lblTheDistance.Caption = "The distance is: " & flxDist.TextMatrix(1, dest)
markLINES
End Sub
Private Sub markLINES()
Dim i As Integer
'For i = iRES_SIZE To 1 Step -1
'Debug.Print sRESULT(i)
'Next i
Dim tagFrom As String
Dim tagTo As String
For i = iRES_SIZE To 2 Step -1
tagFrom = getShapeID_from_cap(sRESULT(i))
tagTo = getShapeID_from_cap(sRESULT(i - 1))
redLINE tagFrom, tagTo
Next i
End Sub
Private Sub redLINE(sFrom As String, sTo As String)
Dim xL As cLine
For Each xL In Form1.theLineCollection
If (xL.sFrom = sFrom) And (xL.sTo = sTo) Then
xL.theObjectLine.BorderColor = vbRed
xL.theObjectLine.BorderWidth = 5
End If
Next xL
End Sub
Private Sub makeAllLines_Black()
Dim xL As cLine
For Each xL In Form1.theLineCollection
xL.theObjectLine.BorderColor = vbBlack
xL.theObjectLine.BorderWidth = 2
Next xL
End Sub
Private Function getShapeID_from_cap(sCap As String) As String
Dim xB As cBlock
For Each xB In Form1.theBlockCollection
If xB.sCaption = sCap Then
getShapeID_from_cap = xB.TagID
End If
Next xB
End Function
Private Function getIndexOfTabName(s As String) As Integer
Dim i As Integer
For i = 1 To flxMap.Cols - 1
If flxMap.TextMatrix(0, i) = s Then
getIndexOfTabName = i
Exit Function
End If
Next i
getIndexOfTabName = -1
End Function
Private Sub Form_Activate()
If PREV_SELECTED_SHAPE = -1 Or SELECTED_SHAPE = -1 Then
lblFromTo.Caption = "nothing selected"
cmdFindShortPath.Enabled = False
Else
cmdFindShortPath.Enabled = True
sFrom = Form1.theBlockCollection(Form1.shp(PREV_SELECTED_SHAPE).Tag).sCaption
sTo = Form1.theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).sCaption
lblFromTo.Caption = "From: " & sFrom & " To: " & sTo
End If
End Sub
Private Function myVl(s As String) As Integer
If s = "INF" Then
myVl = INF
Else
myVl = Val(s)
End If
End Function
Private Sub addTO_RESULT(index As Integer)
iRES_SIZE = iRES_SIZE + 1
sRESULT(iRES_SIZE) = flxMap.TextMatrix(0, index)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -