form1.frm

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

      '将地理对象边界加入总边界中
      If bounds Is Nothing Then
        Set bounds = shapeBounds
      Else
        bounds.Union shapeBounds
      End If
      
      recs.MoveNext
    Loop
    
    Set GetRecordsetBounds = bounds
  End If
End Function

Sub DrawShape(shape As Object, color, style)
  '显示图形
  If Not shape Is Nothing Then
    Dim sym As New Symbol
    sym.color = color
    If style = moTransparentFill Then sym.OutlineColor = color
    sym.style = style
    Map1.DrawShape shape, sym
  End If
End Sub

Sub ExecuteSearch()
  '使用SearchShape或者SearchByDistance执行搜索
  Dim shapes As Object
  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
  
  '重置保留的搜索结果并执行搜索
  Screen.MousePointer = 11
  Set g_selectedFeatures = Nothing
  If StrComp(List1.List(List1.ListIndex), "shape is within [Search Distance] of feature") = 0 Then
      '调用SearchByDistance方法进行搜索
      Set g_selectedFeatures = Map1.Layers(Combo2.ListIndex).SearchByDistance(shapes, Text1.Text, "")
  Else
      '调用SearchByShape方法进行搜索
      Set g_selectedFeatures = Map1.Layers(Combo2.ListIndex).SearchShape(shapes, List1.ListIndex, "")
  End If
  
  Set g_selectedBounds = GetRecordsetBounds(g_selectedFeatures)
    
  Map1.TrackingLayer.Refresh True
  Screen.MousePointer = 0
End Sub

'"搜索工具"组合框控件鼠标单击事件响应代码
Private Sub Combo1_Click()
  
  '清除当前搜索结果
  Set g_searchSet = Nothing
  Set g_searchShape = Nothing
  Set g_selectedFeatures = Nothing
  
End Sub

'"选择"组合框控件鼠标单击事件响应代码
Private Sub Combo2_Click()
  ExecuteSearch
End Sub

Private Sub Form_Load()
  Set g_selectedFeatures = Nothing
  Set g_searchShape = Nothing
  Set g_searchSet = Nothing
  Set g_selectedBounds = Nothing
  Set g_searchBounds = Nothing
  
  '调用MapObjects自带的USA数据库
  '默认路径为C:\Program Files\ESRI\MapObjects2\Samples\Data\USA
  Dim dc As New DataConnection
  dc.Database = "C:\Program Files\ESRI\MapObjects2\Samples\Data\USA"
  If Not dc.Connect Then End
  
  '调入Counties.shp图层
  Dim Counties As New MapLayer
  Counties.GeoDataset = dc.FindGeoDataset("Counties")
  Counties.Symbol.color = moDarkGreen
  Map1.Layers.Add Counties
  
  '调入USHigh图层
  Dim Roads As New MapLayer
  Roads.GeoDataset = dc.FindGeoDataset("USHigh")
  Roads.Symbol.color = moRed
  Map1.Layers.Add Roads
  
  '调入Capitals.shp图层
  Dim Capitals As New MapLayer
  Capitals.GeoDataset = dc.FindGeoDataset("Capitals")
  Capitals.Symbol.color = moCyan
  Map1.Layers.Add Capitals
  
  '设置缺省地图显示范围
  Dim r As New MapObjects2.Rectangle
  r.Left = -96.672334
  r.Right = -85.005616
  r.Bottom = 40.430445
  r.Top = 48.425818
  Map1.Extent = r

  Combo2.AddItem "州府对象"
  Combo2.AddItem "高速公路对象"
  Combo2.AddItem "县对象"
  Combo2.ListIndex = 2
  
  Combo1.AddItem "形状工具"
  Combo1.AddItem "州府"
  Combo1.AddItem "高速公路"
  Combo1.AddItem "县"
  Combo1.ListIndex = 0
  
  '填充搜索方法listbox
  List1.AddItem "moExtentOverlap"
  List1.AddItem "moCommonPoint"
  List1.AddItem "moLineCross"
  List1.AddItem "moCommonLine"
  List1.AddItem "moCommonPointOrLineCross"
  List1.AddItem "moEdgeTouchOrAreaIntersect"
  List1.AddItem "moAreaIntersect"
  List1.AddItem "moAreaIntersectNoEdgeTouch"
  List1.AddItem "moContainedBy"
  List1.AddItem "moContaining"
  List1.AddItem "moContainedByNoEdgeTouch"
  List1.AddItem "moContainingNoEdgeTouch"
  List1.AddItem "moPointInPolygon"
  List1.AddItem "moCentroidInPolygon"
  List1.AddItem "moIdentical"
  List1.AddItem "Search By Distance"
  List1.ListIndex = 0
   
  Label1.Enabled = False
  Text1.Enabled = False
End Sub

Private Sub Form_Resize()
  Map1.Move Map1.Left, Map1.Top, ScaleWidth - Map1.Left, ScaleHeight - Map1.Top
End Sub

'"搜索方式"列表框控件鼠标单击事件响应代码
Private Sub List1_Click()
  If List1.List(List1.ListIndex) = "Shape在地理对象的搜索范围中" Then
    Label1.Enabled = True
    Text1.Enabled = True
  Else
    Label1.Enabled = False
    Text1.Enabled = False
  End If
  ExecuteSearch
End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As StdOle.OLE_HANDLE)
  If g_searchBounds Is Nothing And g_selectedBounds Is Nothing Then Exit Sub
  
  'g_searchSet和g_searchShape其中一个有效
  DrawRecordset g_selectedFeatures, moMagenta, moSolidFill
  DrawRecordset g_searchSet, moYellow, moTransparentFill
  DrawShape g_searchShape, moYellow, moTransparentFill
End Sub

'Map Control鼠标按键按下事件响应代码
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  '若点选了Toolbox中的工具,则跟踪图上用户输入的图形,并依此进行查询
  '查询所依据的图形可能是用户输入的图形(g_searchshape),也可能是图形集(g_searchset)
  Dim searchLayer As Integer
  searchLayer = Combo1.ListIndex - 1
  
  If Toolbar1.Buttons("Points").Value = 1 And searchLayer = -1 Then
    '搜索所依据的图形为用户输入的点 search shape is a user defined point
    Dim pt As MapObjects2.Point
    Set pt = 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 Toolbar1.Buttons("Points").Value = 1 Then
    '从图中选择一个点作为搜索所依据的图形
    Set pt = Map1.ToMapPoint(x, y)
    If (Combo1.ListIndex < 6) Then  '州府和高速公路搜索的允许值为默认
      Set g_searchSet = Map1.Layers(searchLayer).SearchByDistance(pt, 0.05, "")
    Else                            ' 州府
      Set g_searchSet = Map1.Layers(searchLayer).SearchShape(pt, moPointInPolygon, "")
    End If
    Set g_searchBounds = GetRecordsetBounds(g_searchSet)
    Set g_searchShape = Nothing
    ExecuteSearch
    Exit Sub
    
  ElseIf Toolbar1.Buttons("Rectangles").Value = 1 And searchLayer = -1 Then
    '搜索所依据的图形为用户输入的矩形
    Dim r As MapObjects2.Rectangle
    Set r = Map1.TrackRectangle
    Set g_searchShape = r
    Set g_searchBounds = r
    Set g_searchSet = Nothing
    ExecuteSearch
    Exit Sub
    
  ElseIf Toolbar1.Buttons("Rectangles").Value = 1 Then
    '依据用户输入的矩形,得到一个地理对象集,并以此为依据搜索地理对象
    Dim fr As MapObjects2.Rectangle
    Set fr = Map1.TrackRectangle
    Set g_searchSet = Map1.Layers(searchLayer).SearchShape(fr, moEdgeTouchOrAreaIntersect, "")
    Set g_searchBounds = GetRecordsetBounds(g_searchSet)
    Set g_searchShape = Nothing
    ExecuteSearch
    Exit Sub
  
  ElseIf Toolbar1.Buttons("Lines").Value = 1 And searchLayer = -1 Then
    '搜索所依据的图形为用户输入的线段
    Dim l As MapObjects2.Line
    Set l = Map1.TrackLine
    Set g_searchShape = l
    Set g_searchBounds = l.Extent
    Set g_searchSet = Nothing
    ExecuteSearch
    Exit Sub
    
  ElseIf Toolbar1.Buttons("Lines").Value = 1 Then
    '依据用户输入的线段,得到一个地理对象集,并以此为依据搜索地理对象
    Dim fl As MapObjects2.Line
    Set fl = Map1.TrackLine
    Set g_searchSet = Map1.Layers(searchLayer).SearchShape(fl, moEdgeTouchOrAreaIntersect, "")
    Set g_searchBounds = GetRecordsetBounds(g_searchSet)
    Set g_searchShape = Nothing
    ExecuteSearch
    Exit Sub
  
  ElseIf Toolbar1.Buttons("Polygons").Value = 1 And searchLayer = -1 Then
    '搜索所依据的图形为用户输入的多边形
    Dim p As MapObjects2.Polygon
    Set p = Map1.TrackPolygon
    Set g_searchShape = p
    Set g_searchBounds = p.Extent
    Set g_searchSet = Nothing
    ExecuteSearch
    Exit Sub
    
  ElseIf Toolbar1.Buttons("Polygons").Value = 1 Then
    '依据用户输入的多边形,得到一个地理对象集,并以此为依据搜索地理对象
    Dim fp As MapObjects2.Polygon
    Set fp = Map1.TrackPolygon
    Set g_searchSet = Map1.Layers(searchLayer).SearchShape(fp, moEdgeTouchOrAreaIntersect, "")
    Set g_searchBounds = GetRecordsetBounds(g_searchSet)
    Set g_searchShape = Nothing
    ExecuteSearch
    Exit Sub
  End If
  
  '工具栏中没有按钮被选择
  If Toolbar1.Buttons("ZoomIn").Value = 1 Then
    Map1.Extent = Map1.TrackRectangle
    
  ElseIf Toolbar1.Buttons("ZoomOut").Value = 1 Then
    Dim zoomOutRect As MapObjects2.Rectangle
    Set zoomOutRect = Map1.Extent
    zoomOutRect.ScaleRectangle 1.5
    Map1.Extent = zoomOutRect
    
  ElseIf Toolbar1.Buttons("Pan").Value = 1 Then
    Map1.Pan
  End If
End Sub

'"搜索距离"文本框按键事件响应代码
Private Sub Text1_KeyPress(KeyAscii As Integer)
  If (KeyAscii = vbKeyReturn) Then ExecuteSearch
End Sub

'工具栏按钮鼠标单击事件响应代码
Private Sub Toolbar1_ButtonClick(ByVal Button As Button)
  
  If Button.Key = "FullExtent" Then
    '全图显示
    Map1.Extent = Map1.FullExtent
  ElseIf Button.Key = "ClearSelection" Then
    '清除当前搜索结果
    Set g_searchSet = Nothing
    Set g_searchShape = Nothing
    Set g_selectedFeatures = Nothing
    Map1.TrackingLayer.Refresh True
  End If
End Sub