spatial.frm

这个是grs源程序,mo在图象显示上很好,所以大家一定要下载

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "ComDlg32.OCX"
Begin VB.Form frmSpatial 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Spatial selection"
   ClientHeight    =   6075
   ClientLeft      =   15
   ClientTop       =   1380
   ClientWidth     =   4020
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   6075
   ScaleWidth      =   4020
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdExportShapefile 
      Caption         =   "Convert the selected set into a new shapefile"
      Height          =   375
      Left            =   360
      TabIndex        =   15
      Top             =   5640
      Width           =   3375
   End
   Begin VB.CheckBox chkDrawBuffer 
      Caption         =   "Draw buffer area"
      Height          =   255
      Left            =   2280
      TabIndex        =   14
      Top             =   4200
      Value           =   1  'Checked
      Visible         =   0   'False
      Width           =   1695
   End
   Begin VB.PictureBox picSymbol 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   375
      Left            =   540
      ScaleHeight     =   345
      ScaleWidth      =   465
      TabIndex        =   13
      Top             =   1740
      Width           =   495
   End
   Begin VB.TextBox txtDistance 
      Height          =   285
      Left            =   2280
      TabIndex        =   12
      Top             =   3840
      Width           =   1695
   End
   Begin VB.CommandButton cmdApply 
      Caption         =   "Apply selection"
      Height          =   315
      Left            =   480
      TabIndex        =   7
      Top             =   5280
      Width           =   1515
   End
   Begin VB.ComboBox cboMethod 
      Height          =   315
      ItemData        =   "Spatial.frx":0000
      Left            =   240
      List            =   "Spatial.frx":0002
      Style           =   2  'Dropdown List
      TabIndex        =   6
      Top             =   3420
      Width           =   3735
   End
   Begin VB.CommandButton cmdClearSelection 
      Caption         =   "Clear selection"
      Height          =   315
      Left            =   2040
      TabIndex        =   5
      Top             =   5280
      Width           =   1455
   End
   Begin VB.ComboBox cboLayer 
      Height          =   315
      Left            =   240
      Style           =   2  'Dropdown List
      TabIndex        =   3
      Top             =   1320
      Width           =   2655
   End
   Begin VB.ComboBox cboUsing 
      Height          =   315
      Left            =   240
      Style           =   2  'Dropdown List
      TabIndex        =   0
      Top             =   2700
      Width           =   3735
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   0
      Top             =   1680
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      FontSize        =   2.54016e-29
   End
   Begin VB.Label lblDistance 
      Caption         =   "4. Enter distance in map units:"
      Height          =   255
      Left            =   120
      TabIndex        =   11
      Top             =   3840
      Width           =   2295
   End
   Begin VB.Line Line2 
      X1              =   120
      X2              =   3960
      Y1              =   4500
      Y2              =   4500
   End
   Begin VB.Line Line1 
      X1              =   120
      X2              =   3960
      Y1              =   960
      Y2              =   960
   End
   Begin VB.Label lblClickOnSymbol 
      Caption         =   "Click on the symbol to change how selected features are highlighted."
      Height          =   435
      Left            =   1140
      TabIndex        =   10
      Top             =   1680
      Width           =   2535
   End
   Begin VB.Label lblAction 
      Caption         =   $"Spatial.frx":0004
      Height          =   675
      Left            =   120
      TabIndex        =   9
      Top             =   4560
      Width           =   3915
   End
   Begin VB.Label lblDescription 
      Caption         =   $"Spatial.frx":00A4
      Height          =   975
      Left            =   180
      TabIndex        =   8
      Top             =   60
      Width           =   3675
   End
   Begin VB.Label lblWhere 
      Caption         =   "3. Choose a method for spatial selection:"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   3120
      Width           =   3390
   End
   Begin VB.Label lblSelect 
      Caption         =   "1. Choose a layer for selecting features:"
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   1080
      Width           =   3915
   End
   Begin VB.Label lblUsing 
      Caption         =   "2. Choose a shape type for cursor selection or another layer to select against:"
      Height          =   435
      Left            =   120
      TabIndex        =   1
      Top             =   2220
      Width           =   3750
   End
End
Attribute VB_Name = "frmSpatial"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' Results of spatial search
Private g_selectedFeatures As MapObjects2.Recordset

' Search shapes when using other features to search.
Private g_searchSet As MapObjects2.Recordset

' Search shape when using rubberbanded shape to search
Private g_searchShape As Object

Private g_selectedBounds As MapObjects2.Rectangle
Private g_searchBounds As MapObjects2.Rectangle
Private g_searchDistance As Double

Private Sub Form_Load()
  'Position to the right of the main form
  Me.Move frmMain.Left + frmMain.Width, frmMain.Top
  If (Me.Left + Me.Width) > Screen.Width Then
    Me.Left = Screen.Width - Me.Width
  End If
  
  Set g_selectedFeatures = Nothing
  Set g_searchShape = Nothing
  Set g_searchSet = Nothing
  Set g_selectedBounds = Nothing
  Set g_searchBounds = Nothing
  cmdApply.Enabled = False
  txtDistance.Visible = False
  lblDistance.Visible = False
  
  ' fill "Select:" layers combobox
  Dim layer As Object
  Dim i As Integer
  
  i = 0
  For Each layer In frmMain.mapDisp.Layers
    If layer.LayerType = 0 Then
      cboLayer.AddItem layer.Name
      i = i + 1
    End If
  Next layer
  If i > 0 Then cboLayer.ListIndex = 0


  ' fill "Using:" layers combobox
  cboUsing.AddItem "A point shape drawn with the cursor"
  cboUsing.AddItem "A line shape drawn with the cursor"
  cboUsing.AddItem "A rectangle shape drawn with the cursor"
  cboUsing.AddItem "A polygon shape drawn with the cursor"
  cboUsing.ListIndex = 0
  
  ' fill operations listbox
  cboMethod.AddItem "Shape & feature extents overlap"
  cboMethod.AddItem "Shape & feature share a common point"
  cboMethod.AddItem "Shape & feature cross edges"
  cboMethod.AddItem "Shape & feature share a common line"
  cboMethod.AddItem "Shape & feature share common point or cross edges"
  cboMethod.AddItem "Shape & feature intersect"
  cboMethod.AddItem "Shape & feature intersect on interior"
  cboMethod.AddItem "Shape & feature intersect without touching edges"
  cboMethod.AddItem "Feature contains shape"
  cboMethod.AddItem "Shape contains feature"
  cboMethod.AddItem "Feature completely contains shape"
  cboMethod.AddItem "Shape completely contains feature"
  cboMethod.AddItem "Feature contains first point of shape"
  cboMethod.AddItem "Shape contains feature centroid"
  cboMethod.AddItem "Feature is identical to shape"
  cboMethod.AddItem "Shape is within search distance of feature"
  cboMethod.ListIndex = 0
  
  ' Set initial selection color
  picSymbol.BackColor = moMagenta
End Sub

Private Sub Form_Terminate()
'  Call cmdClearSelection
  Set g_selectedFeatures = Nothing
  Set g_searchShape = Nothing
  Set g_searchSet = Nothing
  Set g_selectedBounds = Nothing
  Set g_searchBounds = Nothing
  frmMain.mapDisp.TrackingLayer.Refresh True
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set g_selectedFeatures = Nothing
  Set g_searchShape = Nothing
  Set g_searchSet = Nothing
  Set g_selectedBounds = Nothing
  Set g_searchBounds = Nothing
  frmMain.mapDisp.TrackingLayer.Refresh True
End Sub

Public Sub DrawSelectedFeatures(ByVal hDC As StdOle.OLE_HANDLE)
  
  'This is public because it is used by frmMain.mapDisp.AfterTrackingLayerDraw
  'to draw the selected features onto the map.
  
  If g_searchBounds Is Nothing And g_selectedBounds Is Nothing Then Exit Sub
  
  ' Either g_searchSet or g_searchShape will be valid.
  DrawSpatialRecordset g_selectedFeatures, picSymbol.BackColor, moSolidFill
  DrawSpatialRecordset g_searchSet, moYellow, moTransparentFill
  DrawSpatialShape g_searchShape, moYellow, moTransparentFill
End Sub

Public Sub SelectFeatures(Button As Integer, Shift As Integer, x As Single, y As Single)
  
  ' This is public because it is called by frmMain.mapDisp_MouseDown
  
  ' If one of the shape select tools is active, get
  ' the search shape(s) and use them to select features.
  ' The search shape(s) can either be a simple shape
  ' (g_searchShape) rubberbanded by the user or a set
  ' of features (g_searchSet).
  Dim searchLayer As Integer
  searchLayer = cboUsing.ListIndex - 1
  
  If cboUsing.ListIndex = 0 Then
    ' Select a feature to use as the search shape.
    Dim pt As MapObjects2.Point
    Set pt = frmMain.mapDisp.ToMapPoint(x, y)
    Set g_searchShape = pt
    Dim ptBounds As New MapObjects2.Rectangle
    ptBounds.Left = pt.x
    ptBounds.Top = pt.y
    ptBounds.Right = pt.x
    ptBounds.Bottom = pt.y
    Set g_searchBounds = ptBounds
    Set g_searchSet = Nothing
    ExecuteSearch
    Exit Sub
    
  ElseIf cboUsing.ListIndex = 1 Then
    ' Use a line shape to select features
    Dim l As MapObjects2.Line