spatial.frm

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

    Set l = frmMain.mapDisp.TrackLine
    Set g_searchShape = l
    Set g_searchBounds = l.Extent
    Set g_searchSet = Nothing
    ExecuteSearch
    Exit Sub
    
  ElseIf cboUsing.ListIndex = 2 Then
    ' Use a rectangle shape to select features
    Dim r As MapObjects2.Rectangle
    Set r = frmMain.mapDisp.TrackRectangle
    Set g_searchShape = r
    Set g_searchBounds = r
    Set g_searchSet = Nothing
    ExecuteSearch
    Exit Sub
    
  ElseIf cboUsing.ListIndex = 3 Then
    ' Use a polygon shape to select features
    Dim p As MapObjects2.Polygon
    Set p = frmMain.mapDisp.TrackPolygon
    Set g_searchShape = p
    Set g_searchBounds = p.Extent
    Set g_searchSet = Nothing
    ExecuteSearch
    Exit Sub
  
  End If
  
End Sub

Private Sub DrawSpatialRecordset(recs As MapObjects2.Recordset, color, style)
  ' Draw the features of a RecordSet
  '
  'Called by the DrawSelectedFeatures public procedure above
  
  If Not recs Is Nothing Then
    Dim sym As New MapObjects2.Symbol
    Dim fld As MapObjects2.Field
    sym.color = color
    If style = moTransparentFill Then sym.OutlineColor = color
    sym.style = style
    Set fld = recs("Shape")
    If recs.count = 0 Then Exit Sub
    recs.MoveFirst     ' reset the cursor
    Do While Not recs.EOF ' loop through the records
      frmMain.mapDisp.DrawShape fld.Value, sym
      recs.MoveNext
    Loop
  End If
End Sub

Private Sub DrawSpatialShape(shape As Object, color, style)
  ' draw the shape
  '
  'Called by the DrawSelectedFeatures public procedure above
  
  If Not shape Is Nothing Then
    Dim sym As New MapObjects2.Symbol
    sym.color = color
    If style = moTransparentFill Then sym.OutlineColor = color
    sym.style = style
    frmMain.mapDisp.DrawShape shape, sym
    
    'If searching by distance, draw the search buffer
    'if the user wants to see it.
    If (cboMethod.ListIndex = 15) And (chkDrawBuffer.Value = 1) Then
      Dim symBuffer As New MapObjects2.Symbol
      With symBuffer
        .SymbolType = moFillSymbol
        .style = moLightGrayFill
        .color = color
        .Outline = False
      End With
      Dim shpBuffer As Object
      Set shpBuffer = shape.Buffer(g_searchDistance)
      If Not shpBuffer Is Nothing Then
        frmMain.mapDisp.DrawShape shpBuffer, symBuffer
      Else
        MsgBox "Invalid shape for buffering input", vbInformation, "Spatial Select"
        Beep
      End If
    End If
  End If
End Sub

Private Function GetRecordsetBounds(recs As MapObjects2.Recordset) As MapObjects2.Rectangle
  ' Get the bounds of the recordset
  Set GetRecordsetBounds = Nothing
  If Not recs Is Nothing Then
    Dim bounds As MapObjects2.Rectangle
    Set bounds = Nothing
    Dim fld As MapObjects2.Field
    Set fld = recs("Shape")
    If recs.count = 0 Then Exit Function
    
    ' For each feature in recordset...
    recs.MoveFirst
    Do While Not recs.EOF
    
      ' get shape bounds
      Dim shapeBounds As MapObjects2.Rectangle
      If fld.Type = moPoint Then
        Dim pt As MapObjects2.Point
        Set pt = fld.Value
        Dim ptBounds As New MapObjects2.Rectangle
        ptBounds.Left = pt.x
        ptBounds.Top = pt.y
        ptBounds.Right = pt.x
        ptBounds.Bottom = pt.y
        Set shapeBounds = ptBounds
      ElseIf fld.Type = moLine Then
        Dim l As MapObjects2.Line
        Set l = fld.Value
        Set shapeBounds = l.Extent
      ElseIf fld.Type = moPolygon Then
        Dim p As MapObjects2.Polygon
        Set p = fld.Value
        Set shapeBounds = p.Extent
      ElseIf fld.Type = moPoints Then
        Dim pts As MapObjects2.Points
        Set pts = fld.Value
        Set shapeBounds = pts.Extent
      End If
      
      ' add shape bounds to total
      If bounds Is Nothing Then
        Set bounds = shapeBounds
      Else
        bounds.Union shapeBounds
      End If
      
      recs.MoveNext
    Loop
    
    Set GetRecordsetBounds = bounds
  End If
End Function

Private Sub ExecuteSearch()

  'If no layers, do nothing.
  If cboLayer.ListIndex = -1 Then Exit Sub
  
  'We're either searching with a single shape or a record set.
  'The search routines don't care, so, put the search shape(s)
  'in a single variable called shapes.
  Dim shapes As Object
  Dim curIndex As Integer
  Set shapes = Nothing
  If Not g_searchShape Is Nothing Then Set shapes = g_searchShape
  If Not g_searchSet Is Nothing Then Set shapes = g_searchSet
  If shapes Is Nothing Then Exit Sub
  
  'Reset the selection and execute the search
  Screen.MousePointer = 11
  Set g_selectedFeatures = Nothing
  Dim curLayer As MapObjects2.MapLayer
  
  Set curLayer = frmMain.mapDisp.Layers(cboLayer.ListIndex)
  If StrComp(cboMethod.List(cboMethod.ListIndex), "Shape is within search distance of feature") = 0 Then
      'Execute the SearchByDistance method on selected layer
      Set g_selectedFeatures = curLayer.SearchByDistance(shapes, g_searchDistance, "")
  Else
      'Execute the selected SearchByShape method on selected layer.
      Set g_selectedFeatures = curLayer.SearchShape(shapes, cboMethod.ListIndex, "")
  End If
  
  Set g_selectedBounds = GetRecordsetBounds(g_selectedFeatures)
' Remove any existing search by layer selection in the combo box.
  curIndex = cboUsing.ListIndex
  If cboUsing.ListCount = 5 Then cboUsing.RemoveItem 4
  cmdApply.Enabled = False
' Add search by layer expression if there is a valid selected set, and
' the selected set is not from an SDE layer.
  If Not g_selectedFeatures Is Nothing Then
    If g_selectedFeatures.count > 0 Then
      cboUsing.AddItem "Shapes from the " & curLayer.Name & " layer"
      If curIndex = 4 Then
        cboUsing.ListIndex = 4
        cmdApply.Enabled = True
      End If
    End If
  Else
    If curIndex = 4 Then cboUsing.ListIndex = 0
  End If
  
  frmMain.mapDisp.TrackingLayer.Refresh True
  Screen.MousePointer = 0
End Sub

Private Sub cboUsing_Click()
  If cboUsing.ListIndex = 4 Then
    cmdApply.Enabled = True
  Else
    cmdApply.Enabled = False
  End If
End Sub


Private Sub cboLayer_Click()
'  ExecuteSearch
End Sub


Private Sub cmdApply_Click()
  If txtDistance.Visible Then
    g_searchDistance = txtDistance.text
  Else
    Set g_searchSet = g_selectedFeatures
    Set g_searchBounds = GetRecordsetBounds(g_selectedFeatures)
    Set g_searchShape = Nothing
  End If
  
  ExecuteSearch

End Sub

Private Sub cmdClearSelection_Click()
  Set g_selectedFeatures = Nothing
  Set g_searchShape = Nothing
  Set g_searchSet = Nothing
  Set g_selectedBounds = Nothing
  Set g_searchBounds = Nothing
  If cboUsing.ListCount = 5 Then
    cboUsing.RemoveItem 4
    cboUsing.ListIndex = 0
  End If
  If StrComp(cboMethod.List(cboMethod.ListIndex), "Shape is within search distance of feature") <> 0 Then
    cmdApply.Enabled = False
  End If
  frmMain.mapDisp.TrackingLayer.Refresh True
End Sub

Private Sub cmdExportShapefile_Click()

Dim newmlyr As New MapObjects2.MapLayer
Dim gds As MapObjects2.GeoDataset
Dim recs As MapObjects2.Recordset
Dim fullpath As String

'If there is a selected set of features, write
'them out to a new shapefile.

'If no features are selected, bail out.
If g_selectedFeatures Is Nothing Then
  MsgBox "No features are selected.", vbCritical, "Stop"
  Exit Sub
End If

'Have the user provide a name and location for
'the new shapefile.
CommonDialog1.Filter = "ESRI Shapefiles (*.shp)|*.shp"
CommonDialog1.ShowSave
If Len(CommonDialog1.filename) = 0 Then Exit Sub
fullpath = CommonDialog1.filename

'Export the selected set out to a new shapefile.
'Use the hourglass mouse pointer
Screen.MousePointer = vbHourglass
Set gds = g_selectedFeatures.Export(fullpath)
Screen.MousePointer = vbDefault

'Put the new GeoDataset into the new MapLayer
Set newmlyr.GeoDataset = gds
'Use the same color chosen for the selection set.
newmlyr.Symbol.color = picSymbol.BackColor

'Add the new layer to the map
frmMain.mapDisp.Layers.Add newmlyr

'Put the new shapefile MapLayer into the Map control
frmMain.mapDisp.Layers.Add newmlyr
frmMain.legMapDisp.LoadLegend
frmMain.mapDisp.Refresh

'Clean up
Set g_selectedFeatures = Nothing
Set g_searchSet = Nothing
Set g_searchShape = Nothing

'Unload the spatial select form.
Unload Me

End Sub

Private Sub cboMethod_Click()
  txtDistance.Visible = False
  lblDistance.Visible = False
  chkDrawBuffer.Visible = False
  If StrComp(cboMethod.List(cboMethod.ListIndex), "Shape is within search distance of feature") = 0 Then
    txtDistance.Visible = True
    lblDistance.Visible = True
    chkDrawBuffer.Visible = True
  Else
    If cboUsing.ListIndex < 4 Then ExecuteSearch
  End If
End Sub

Private Sub picSymbol_Click()
  CommonDialog1.ShowColor
  picSymbol.BackColor = CommonDialog1.color
End Sub

Private Sub txtdistance_KeyPress(KeyAscii As Integer)
  If (KeyAscii = vbKeyReturn) And txtDistance.text <> "" Then
    g_searchDistance = txtDistance.text
    Call ExecuteSearch
  End If
End Sub