form1.frm

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

'被选中的山峰的数据集
Dim selRecs As MapObjects2.Recordset

'英尺与米的单位转换常量
Dim f_to_m As Double
Dim m_to_f As Double
Dim text_height As Double
Dim scale_width As Double
Dim theBenEasting As Long
Dim theBenNorthing As Long

Sub DrawRecordset(recs As MapObjects2.Recordset)
  '显示被选中的山峰
  If Not recs Is Nothing Then
    Dim sym As New MapObjects2.Symbol
    sym.SymbolType = moPointSymbol
    sym.Color = moYellow
    sym.Style = moTriangleMarker
    sym.Size = 6
    Map1.DrawShape recs, sym
  End If
End Sub

Private Sub Form_Load()

  '初始化
  Set selRecs = Nothing
  f_to_m = 0.3048037
  m_to_f = 3.2808
  text_height = 2000
  scale_width = 50000
  theBenEasting = 216600
  theBenNorthing = 771300

  '连接地理数据库
  '这里连接的是MapObjects自带的Scotland地理数据
  '默认路径在C:\Program Files\ESRI\MapObjects2\Samples\Data\Scotland
  Dim dc As New DataConnection
  dc.Database = "C:\Program Files\ESRI\MapObjects2\Samples\Data\Scotland"
  If Not dc.Connect Then End
  
  '读入Scotcoast图层
  Dim Scotcoast As New MapObjects2.MapLayer
  Scotcoast.GeoDataset = dc.FindGeoDataset("Scotcoast")
  Scotcoast.Symbol.Color = moLightYellow
  Map1.Layers.Add Scotcoast
  
  '读入mountains图层
  Dim Mountains As New MapObjects2.MapLayer
  Mountains.GeoDataset = dc.FindGeoDataset("mountains")
  Mountains.Symbol.Color = moWhite
  Mountains.Symbol.Size = 6
  Mountains.Symbol.Style = moTriangleMarker
  Map1.Layers.Add Mountains
  
  '为同时显示山峰的文本标注(使用LabelPlacer对象)和山峰的图形(使用ZRenderer对象和ValueMapRenderer对象)
  '需要读入mountains图层两次
  Dim Mountainslp As New MapObjects2.MapLayer
  Mountainslp.GeoDataset = dc.FindGeoDataset("mountains")
  Mountainslp.Symbol.Size = 0
  Map1.Layers.Add Mountainslp
  Map1.MousePointer = moZoomIn
  
End Sub

Private Sub selection_enable(bool As Boolean)
  '确定是否已选择山峰，以决定界面上一些控件的有效性
  sel2d.Enabled = bool
  sel3d.Enabled = bool
  If sel3d.Value Then
    ceiling.Enabled = bool
    floor.Enabled = bool
  End If

End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)
  
  If selRecs Is Nothing Then Exit Sub
  DrawRecordset selRecs

End Sub

Private Sub Map1_BeforeLayerDraw(ByVal index As Integer, ByVal hDC As stdole.OLE_HANDLE)

  If Map1.Extent.Width > scale_width Then
    LPlacer.Enabled = False
    Map1.Layers(0).Visible = False
  Else
    LPlacer.Enabled = True
    make_LPlacer
    Map1.Layers(0).Visible = LPlacer
  End If

End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

  If Toolbar1.Buttons("ZoomIn").Value = 1 Then
    '放大
    Map1.Extent = Map1.TrackRectangle
    
  ElseIf Toolbar1.Buttons("ZoomOut").Value = 1 Then
    '缩小
    Dim zoomOutRect As MapObjects2.Rectangle
    Dim newRect As MapObjects2.Rectangle
    
    Set zoomOutRect = Map1.TrackRectangle
    Set newRect = Map1.Extent
    ow = zoomOutRect.Width
    If (ow > 0) Then
      newRect.ScaleRectangle Map1.Extent.Width / ow
    Else
      newRect.ScaleRectangle 1.5
    End If
     
    Map1.Extent = newRect
         
  ElseIf Toolbar1.Buttons("Pan").Value = 1 Then
    '移动地图
    Map1.Pan
  
  ElseIf Toolbar1.Buttons("Rect").Value = 1 Then
    '选择二维矩形或三维立方体中的山峰
    Dim rect As MapObjects2.Rectangle
    Set rect = Map1.TrackRectangle
    If (rect.Width > 0) Then
      Call selrect(rect)
    End If
  
  End If
End Sub

Public Sub selrect(rect As MapObjects2.Rectangle)
  '查询二维矩形或三维立方体中的山峰
  If (sel3d.Value) Then
    '若是三维立方体,则设置floor属性和ceiling属性
    rect.floor = floor.Text
    rect.ceiling = ceiling.Text
  End If

  Set selRecs = Map1.Layers(0).SearchShape(rect, moContaining, "")
  Clue.Caption = selRecs.Count & "个山峰已被选择"
  Map1.TrackingLayer.Refresh True
    
End Sub

'"无"单选框鼠标单击事件响应代码
Private Sub NoRen_Click()

  If NoRen Then
     Map1.Layers(1).Renderer = Nothing
     PictureLeg.Picture = LoadPicture()
     Map1.Refresh
  End If

End Sub

Private Sub sel2d_Click()
  floor.Enabled = False
  ceiling.Enabled = False
  MsgBox "将选择二维矩形内的山峰,忽略Z值."
End Sub

Private Sub sel3d_Click()
  floor.Enabled = True
  ceiling.Enabled = True
  MsgBox "将选择三维立方体内的内的山峰,立方体的底部为" & floor & ",顶部为" & ceiling
End Sub

Private Sub make_LPlacer()
  '建立一个LabelPlacer对象,以显示
  Dim lp As New MapObjects2.LabelPlacer
  Dim fnt As New StdFont
  fnt.Name = "Arial"
  fnt.Bold = True

  With lp
    Set .DefaultSymbol.Font = fnt
    .UseDefault = True
    
    .DefaultSymbol.Height = text_height * Map1.Extent.Height / scale_width
    .Field = "NAME"
    .DrawBackground = True '显示线段
  End With

  Map1.Layers(0).Renderer = lp

End Sub

'"ZRenderer(高度的单位为英尺)"单选框鼠标单击事件响应代码
Private Sub Zren_Click()
  '建立一个ZRenderer以山峰高度为基础着色
  Dim Zren As New MapObjects2.ZRenderer
  Dim f_to_m As Double

  f_to_m = 917 / 3000 '将英尺近似转换为米
  With Zren
    '山峰按高度分六个等级
    .BreakCount = 6
    '设置每个等级的山峰高度范围
    .Break(0) = 1000 * f_to_m
    .Break(1) = 2500 * f_to_m
    .Break(2) = 3000 * f_to_m
    .Break(3) = 3500 * f_to_m
    .Break(4) = 4000 * f_to_m
    .Break(5) = 4500 * f_to_m
    
    .SymbolType = moPointSymbol
    '按山峰高度不同设置不同大小的符号
    For i = 0 To .BreakCount - 1
        .Symbol(i).Color = moGray
        .Symbol(i).Style = moTriangleMarker
        .Symbol(i).Size = (i) * 3
    Next i

  End With
  '将ZRenderer赋值给MapLayer
  Set Map1.Layers(1).Renderer = Zren
  PictureLeg.Picture = LoadPicture(App.Path & "\ZLeg.bmp")
  Map1.Refresh
  
End Sub

'"ValueMapRenderer (按照类型着色)"单选框鼠标单击事件响应代码
Private Sub Vren_Click()
  '建立一个ValueMapRendere,以山峰类型为基础着色
  Dim VRen As New MapObjects2.ValueMapRenderer

  With VRen
    '3种类型的山峰
    .ValueCount = 3
    .Field = "Type"
    .SymbolType = moPointSymbol
    .Value(0) = "Munro"
    .Value(1) = "Corbett"
    .Value(2) = "Other"
    
    '设置每种山峰的颜色
    .SymbolType = moPointSymbol
    .Symbol(0).Color = moBlue
    .Symbol(1).Color = moRed
    .Symbol(2).Color = moGreen

    '设置Symbol的属性
    For i = 0 To .ValueCount - 1
      .Symbol(i).Size = 6
      .Symbol(i).Style = moTriangleMarker
    Next i
    
  End With
  '将ValueMapRenderer赋值给MapLayer
  Set Map1.Layers(1).Renderer = VRen
  PictureLeg.Picture = LoadPicture(App.Path & "\classleg.bmp")
  Map1.Refresh
End Sub

'工具栏鼠标单击事件相应代码
Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)
  '依据Botton的Key属性确定单击的是哪个按钮
  
  If Button.Key = "FullExtent" Then
    Map1.Extent = Map1.FullExtent
  ElseIf Button.Key = "ZoomIn" Then
    Map1.MousePointer = moZoomIn
    Call selection_enable(False)
  ElseIf Button.Key = "ZoomOut" Then
    Map1.MousePointer = moZoomOut
    Call selection_enable(False)
  ElseIf Button.Key = "Pan" Then
    Map1.MousePointer = moPan
    Call selection_enable(False)
  ElseIf Button.Key = "Rect" Then
    Map1.MousePointer = moCross
    Call selection_enable(True)
  ElseIf Button.Key = "" Then

  End If
End Sub