📄 pfind20.frm
字号:
VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Begin VB.Form frmPfind
Caption = "Form1"
ClientHeight = 4950
ClientLeft = 60
ClientTop = 345
ClientWidth = 8505
LinkTopic = "Form1"
ScaleHeight = 4950
ScaleWidth = 8505
StartUpPosition = 3 'Windows Default
Begin MapObjects2.Map Map1
Height = 4695
Left = 120
TabIndex = 11
Top = 120
Width = 5415
_Version = 131072
_ExtentX = 9551
_ExtentY = 8281
_StockProps = 225
BackColor = 16777215
BorderStyle = 1
Contents = "pfind20.frx":0000
End
Begin VB.HScrollBar HScroll1
Height = 255
Left = 5880
Max = 24
Min = 1
TabIndex = 9
Top = 4440
Value = 6
Width = 2415
End
Begin VB.Frame Frame1
Height = 1335
Left = 5640
TabIndex = 5
Top = 100
Width = 2775
Begin VB.OptionButton Option2
Caption = "Load US Highways"
Height = 255
Index = 1
Left = 240
TabIndex = 8
Top = 960
Width = 2175
End
Begin VB.OptionButton Option2
Caption = "Load Atlanta streets"
Height = 255
Index = 0
Left = 240
TabIndex = 7
Top = 720
Value = -1 'True
Width = 2175
End
Begin VB.Label Label2
Caption = "Pathfinder Example"
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 240
TabIndex = 6
Top = 240
Width = 2415
End
End
Begin VB.CommandButton Command1
Caption = "Find path and display it"
Height = 495
Left = 6120
TabIndex = 4
Top = 2880
Width = 1815
End
Begin VB.OptionButton Option1
Caption = "point on closest end point"
Height = 255
Index = 2
Left = 6000
TabIndex = 2
Top = 2280
Width = 2175
End
Begin VB.OptionButton Option1
Caption = "click point"
Height = 255
Index = 1
Left = 6000
TabIndex = 1
Top = 2040
Width = 1095
End
Begin VB.OptionButton Option1
Caption = "zoom/pan tool"
Height = 255
Index = 0
Left = 6000
TabIndex = 0
Top = 1800
Value = -1 'True
Width = 1455
End
Begin VB.Label Label3
Caption = "Point marker size"
Height = 255
Left = 5880
TabIndex = 10
Top = 4200
Width = 2055
End
Begin VB.Label Label1
Caption = "MOUSE AS A:"
Height = 255
Left = 5880
TabIndex = 3
Top = 1560
Width = 1215
End
End
Attribute VB_Name = "frmPfind"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim dc As New MapObjects2.DataConnection
Dim gds As MapObjects2.GeoDataset
Dim mlyr As New MapObjects2.MapLayer
Dim pt As New MapObjects2.Point
Dim ptsym As New MapObjects2.Symbol
Dim linesym As New MapObjects2.Symbol
Dim pathline As New MapObjects2.Line
Dim twopointcoll As New VBA.Collection
Private Sub Command1_Click()
If twopointcoll.Count = 2 Then
Dim dist As Double
dist = twopointcoll(1).DistanceTo(twopointcoll(2))
If dist > 0 Then
Dim thepf As New MoPathFinder.PathFinder
If dc.Connect Then
Set thepf.GeoDataset = gds
Set pathline = thepf.FindPath(twopointcoll(1), twopointcoll(2))
Map1.TrackingLayer.Refresh True
End If
End If
End If
End Sub
Private Sub Form_Load()
dc.Database = App.Path
dc.Connect
Set gds = dc.FindGeoDataset("streets")
Set mlyr.GeoDataset = gds
mlyr.Symbol.Color = moBlue
Map1.Layers.Add mlyr
ptsym.SymbolType = moPointSymbol
ptsym.Style = moTriangleMarker
ptsym.Color = moRed
ptsym.Size = HScroll1.Value
linesym.SymbolType = moLineSymbol
linesym.Style = moSolidLine
linesym.Color = moDarkGreen
linesym.Size = 3
End Sub
Private Sub HScroll1_Change()
ptsym.Size = HScroll1.Value
Map1.TrackingLayer.Refresh True
End Sub
Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As Stdole.OLE_HANDLE)
If pathline.Length > 0 Then
Map1.DrawShape pathline, linesym
End If
Dim i As Byte
If twopointcoll.Count > 0 Then
For i = 1 To twopointcoll.Count
Map1.DrawShape twopointcoll(i), ptsym
Next
End If
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Set pt = Map1.ToMapPoint(x, y)
Select Case True
Case Option1(0)
DoZoom Button, Shift
Case Option1(1)
ClickPoint pt.x, pt.y
Case Option1(2)
ClickPointFindClosestEnd pt.x, pt.y
End Select
End Sub
Private Sub Option2_Click(Index As Integer)
If Not dc.Connected Then
dc.Database = App.Path
dc.Connect
End If
Map1.Layers.Clear
Set gds = Nothing
Set mlyr = Nothing
Select Case Index
Case 0
Set gds = dc.FindGeoDataset("streets")
Case 1
Set gds = dc.FindGeoDataset("ushigh")
End Select
Set mlyr.GeoDataset = gds
mlyr.Symbol.Color = moBlue
Map1.Layers.Add mlyr
Set Map1.Extent = Map1.FullExtent
End Sub
Public Sub DoZoom(Button As Integer, Shift As Integer)
If Shift = 0 Then
If Button = 1 Then
Set Map1.Extent = Map1.TrackRectangle
Else
Map1.Pan
End If
Else
If Button = 1 Then
Dim rect As New MapObjects2.Rectangle
Set rect = Map1.Extent
rect.ScaleRectangle (1.2)
Set Map1.Extent = rect
Else
Set Map1.Extent = Map1.FullExtent
End If
End If
End Sub
Public Sub ClickPoint(x As Double, y As Double)
If twopointcoll.Count = 2 Then
twopointcoll.Remove 1
End If
twopointcoll.Add pt
Map1.TrackingLayer.Refresh True
End Sub
Public Sub ClickPointFindClosestEnd(x As Double, y As Double)
Dim recs As MapObjects2.Recordset
Dim lineClicked As New MapObjects2.Line
Dim firstPart As MapObjects2.Points
Dim lastPart As MapObjects2.Points
Dim ptClicked As New MapObjects2.Point
Dim ptStart As New MapObjects2.Point
Dim ptEnd As New MapObjects2.Point
Dim ptClosest As New MapObjects2.Point
Dim tol As Double
If twopointcoll.Count = 2 Then
twopointcoll.Remove 1
End If
ptClicked.x = x
ptClicked.y = y
tol = Map1.ToMapDistance(3 * Screen.TwipsPerPixelX)
Set recs = Map1.Layers(0).SearchByDistance(pt, tol, "")
Set lineClicked = recs.Fields("shape").Value
Set firstPart = lineClicked.Parts(0)
Set lastPart = lineClicked.Parts(lineClicked.Parts.Count - 1)
Set ptStart = firstPart.Item(0)
Set ptEnd = lastPart.Item(lastPart.Count - 1)
If ptClicked.DistanceTo(ptStart) < ptClicked.DistanceTo(ptEnd) Then
Set ptClosest = ptStart
Else
Set ptClosest = ptEnd
End If
twopointcoll.Add ptClosest
Map1.TrackingLayer.Refresh True
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -