spatial.frm

用于河南省主体功能区区划的一个小地理信息系统

    'Select a feature to use as the search shape.
    Dim pt As MapObjects2.Point
    Set pt = frmmain.Map1.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
    Set l = frmmain.Map1.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.Map1.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.Map1.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.Map1.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.Map1.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 = moLightGray
        .Outline = False
      End With
      
      Dim shpBuffer As Object
      If TxtDistance.text = "" Then TxtDistance.text = 0
      Set shpBuffer = shape.Buffer(CDbl(TxtDistance.text))
      If Not shpBuffer Is Nothing Then
        frmmain.Map1.DrawShape shpBuffer, symBuffer
'      Else
'        MsgBox "无效图形，不能进行缓冲区输入", vbInformation, "空间选择"
'        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.Map1.Layers(cboLayer.ListIndex)
  
  If StrComp(cboMethod.List(cboMethod.ListIndex), "图形在图层要素一定距离内") = 0 Then
      'Execute the SearchByDistance method on selected layer
      If TxtDistance.text = "" Then TxtDistance.text = 0
      Set g_selectedFeatures = curLayer.SearchByDistance(shapes, CDbl(TxtDistance.text), "")
  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 "来自 " & curLayer.name & " 图层的图形特征"
      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.Map1.TrackingLayer.Refresh True
  Screen.MousePointer = 0
End Sub

Private Sub cboUsing_Click()
  If cboUsing.ListIndex = 4 Then
    cmdApply.Enabled = True
'    txtDistance.Visible = False
'    lblDistance.Visible = False
'    chkDrawBuffer.Visible = False
  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
    MsgBox "该种情况下操作无效！", vbExclamation, "提示"
    Exit Sub
  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), "图形在图层要素一定距离内") <> 0 Then
    cmdApply.Enabled = False
  End If
  frmmain.Map1.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.Map1.Layers.Add newmlyr

'Put the new shapefile MapLayer into the Map control
frmmain.Map1.Layers.Add newmlyr
frmmain.legend1.LoadLegend
frmmain.Map1.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), "图形在图层要素一定距离内") = 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