findclosest.frm

最短路径查询 用户可以随便的查询出其最想要达到的地点

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4845
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7590
   LinkTopic       =   "Form1"
   ScaleHeight     =   4845
   ScaleWidth      =   7590
   StartUpPosition =   2  '屏幕中心
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   6960
      Top             =   360
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.OptionButton Option3 
      Caption         =   "Option3"
      Height          =   375
      Left            =   5160
      TabIndex        =   7
      Top             =   4080
      Value           =   -1  'True
      Width           =   2175
   End
   Begin VB.OptionButton Option2 
      Caption         =   "Option2"
      ForeColor       =   &H80000008&
      Height          =   375
      Left            =   5160
      TabIndex        =   5
      Top             =   3000
      Width           =   2175
   End
   Begin VB.OptionButton Option1 
      BackColor       =   &H80000018&
      Caption         =   "Option1"
      ForeColor       =   &H8000000D&
      Height          =   375
      Left            =   5160
      TabIndex        =   4
      Top             =   2520
      Width           =   2175
   End
   Begin MapObjects2.Map Map1 
      Height          =   4575
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   4935
      _Version        =   131072
      _ExtentX        =   8705
      _ExtentY        =   8070
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "findClosest.frx":0000
   End
   Begin VB.CheckBox Check1 
      Caption         =   "Check1"
      Height          =   375
      Left            =   5160
      TabIndex        =   1
      Top             =   840
      Value           =   1  'Checked
      Width           =   1215
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   495
      Left            =   5400
      TabIndex        =   0
      Top             =   120
      Width           =   1215
   End
   Begin VB.Label Label3 
      Caption         =   "Label3"
      ForeColor       =   &H000000FF&
      Height          =   495
      Left            =   5280
      TabIndex        =   8
      Top             =   1320
      Width           =   1935
   End
   Begin VB.Label Label2 
      Caption         =   "Label2"
      Height          =   375
      Left            =   5160
      TabIndex        =   6
      Top             =   3600
      Width           =   2175
   End
   Begin VB.Label Label1 
      Caption         =   "Label1"
      Height          =   375
      Left            =   5160
      TabIndex        =   3
      Top             =   2040
      Width           =   2055
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim foundShape As Object
Dim sym As New MapObjects2.Symbol
Private Const SEARCHTOLPIXELS = 6
Dim bufClick As MapObjects2.Polygon
Public recs As MapObjects2.Recordset
Private Declare Function InitCommonControls Lib "comctl32.dll" () As Long



Private Sub Form_Initialize()
InitCommonControls
End Sub


Private Sub Command1_Click()

'Add Layer to the map
  Dim dc As New DataConnection
  Dim gs As GeoDataset
  Dim name As String
  Dim layer As MapObjects2.MapLayer
  
  CommonDialog1.Filter = "ESRI Shapefiles (*.shp)|*.shp"
  CommonDialog1.ShowOpen
  If Len(CommonDialog1.FileName) = 0 Then Exit Sub
  dc.Database = CurDir
  If Not dc.Connect Then Exit Sub
  
  name = Left(CommonDialog1.FileTitle, Len(CommonDialog1.FileTitle) - 4)

  Set gs = dc.FindGeoDataset(name)

  If gs Is Nothing Then Exit Sub
   
  Set layer = New MapLayer
  layer.GeoDataset = gs
  layer.Symbol.Color = moLightGray
  Map1.Layers.Clear
  
  Map1.Layers.Add layer
  
End Sub

Private Sub Form_Load()

Command1.Caption = "加载图层"
Check1.Caption = "选择要素"
Label1.Caption = "使用方法SearchShape"
Option1.Caption = "moPointInPolygon"
Option2.Caption = "moAreaIntersect"

Label2.Caption = "使用方法SearchByDistance"
Option3.Caption = "SearchBydistance"
CommonDialog1.InitDir = App.Path & "\YNprj"
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unload Form2
End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As Stdole.OLE_HANDLE)


If Not foundShape Is Nothing And _
       Map1.Layers.Count > 0 Then
  Select Case Map1.Layers(0).shapeType
    Case moPoint
      sym.SymbolType = moPointSymbol
      sym.Style = Map1.Layers(0).Symbol.Style
      sym.Color = moYellow
    Case moLine
      sym.SymbolType = moLineSymbol
      sym.Style = moSolidLine
      sym.Color = moYellow
    Case moPolygon
      sym.SymbolType = moFillSymbol
      sym.Style = moSolidFill
      sym.Color = moYellow
  End Select
  
  Map1.DrawShape foundShape, sym
End If
If Not bufClick Is Nothing Then
 ' Map1.DrawShape ptClick, sym
  ' Dim buffEventPt As New MapObjects2.GeoEvent
 '  Set buffEventPt = Map1.TrackingLayer.AddEvent(ptClick, 1)
 Dim symbf As New MapObjects2.Symbol
 symbf.SymbolType = moFillSymbol
 symbf.Style = moGrayFill
 symbf.Color = moBlue
    Map1.DrawShape bufClick, symbf
End If
Set foundShape = Nothing
Set bufClick = Nothing
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Map1.Layers.Count = 0 Then Exit Sub
If Option1.Value = True And Map1.Layers(0).shapeType <> moPolygon Then
 MsgBox "非多边形要素图层，不支持此查询"
 Exit Sub
End If

If Check1.Value = 1 Then
  FindFeature x, y
 
 Else
  
  If Shift = 0 Then
    If Button = 1 Then
      Set Map1.Extent = Map1.TrackRectangle
     Else
      Map1.Pan
    End If
   Else
    If Button = vbLeftButton 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 If

End Sub

Public Sub FindClosest(ByVal x As Double, ByVal y As Double)

Dim minDist As Double
Dim thisDist As Double
Dim mapPt As MapObjects2.Point

Dim subrecs As MapObjects2.Recordset
Dim strFID As String
Dim shp As Object
Set mapPt = Map1.ToMapPoint(x, y)
'Set recs = Map1.Layers(0).SearchShape(Map1.Extent, moAreaIntersect, "")
Set recs = Map1.Layers(0).SearchShape(Map1.Extent, moEdgeTouchOrAreaIntersect, "")
minDist = mapPt.DistanceTo(recs.Fields("shape").Value)
 strFID = recs.Fields("FeatureID").ValueAsString
    Set subrecs = Map1.Layers(0).SearchExpression("""FeatureID"" = " & strFID)

'recs.MoveNext
Do While Not recs.EOF
  Set shp = recs.Fields("shape").Value
  thisDist = shp.DistanceTo(mapPt)
  '
 ' Map1.FlashShape shp, 1
  If thisDist < minDist Then
    minDist = thisDist
  
    strFID = recs.Fields("FeatureID").ValueAsString
    Set subrecs = Map1.Layers(0).SearchExpression("""FeatureID"" = " & strFID)
  End If
  recs.MoveNext
Loop
Set recs = subrecs
Set foundShape = recs.Fields("shape").Value
Map1.Refresh

End Sub
Public Sub FindPolygon(pt As MapObjects2.Point)
Dim shp As Object

Set recs = Map1.Layers(0).SearchShape(pt, moPointInPolygon, "")
If recs.Count = 0 Then Exit Sub
Set shp = recs.Fields("Shape").Value
Set foundShape = shp
Map1.Refresh
End Sub

Public Sub FindLineOrPoint(ByVal x As Double, ByVal y As Double)

Dim shp As Object
Dim pt As New MapObjects2.Point
Dim theTol As Double

theTol = Map1.ToMapDistance(SEARCHTOLPIXELS * Screen.TwipsPerPixelX)
Label3.Caption = "tolerence:" & theTol & vbCrLf & "TPPX:" & Screen.TwipsPerPixelX
Set pt = Map1.ToMapPoint(x, y)
Set recs = Map1.Layers(0).SearchByDistance(pt, theTol, "")

If recs.Count = 0 Then Exit Sub
    recs.MoveFirst
    Set shp = recs.Fields("Shape").Value
    Set foundShape = shp
    Set bufClick = pt.Buffer(theTol, Map1.Extent) '
    Map1.Refresh

End Sub
Public Sub FindFeature(ByVal x As Double, ByVal y As Double)
 If Option1.Value = True Then
    Dim pt As New MapObjects2.Point
    Set pt = Map1.ToMapPoint(x, y)
    FindPolygon pt
 ElseIf Option2.Value = True Then
    Call FindClosest(x, y)
 ElseIf Option3.Value = True Then
    Call FindLineOrPoint(x, y)
 End If
    
  If recs.Count = 0 Then Exit Sub
   setlist recs
    Form2.Show
    Form2.ZOrder (0)
   
 End Sub
 
 Public Sub setlist(recs As MapObjects2.Recordset)
   Dim clmX As ColumnHeader
   Dim itmX As ListItem
   Dim i As Integer
Form2.ListView1.ColumnHeaders.Clear
Form2.ListView1.ListItems.Clear
   Form2.ListView1.View = lvwReport
   'For i = 1 To 3
        Set clmX = Form2.ListView1.ColumnHeaders.Add()
      clmX.Text = "序号"
        Set clmX = Form2.ListView1.ColumnHeaders.Add()
      clmX.Text = "属性"
        Set clmX = Form2.ListView1.ColumnHeaders.Add()
      clmX.Text = "属性值"
      
   'Next i
   
   '添加 10 个具有相同图标的项目到列表中

 '  For i = 1 To 10
  '    Set itmX = ListView1.ListItems.Add()
  '    itmX.Text = "ListItem " & i
 '     itmX.SubItems(1) = "Subitem 1"
 '     itmX.SubItems(2) = "Subitem 2"
 '  Next i
   
   Dim mfield As Object
   i = 0
   For Each mfield In recs.Fields
     i = i + 1
      Set itmX = Form2.ListView1.ListItems.Add()
      itmX.Text = i
      itmX.SubItems(1) = mfield.name
      itmX.SubItems(2) = mfield.ValueAsString
   Next
 
 End Sub