thematicmap.frm

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

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Begin VB.Form Form1 
   Caption         =   "Renderer对象使用实例"
   ClientHeight    =   4905
   ClientLeft      =   1365
   ClientTop       =   1515
   ClientWidth     =   8850
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4905
   ScaleWidth      =   8850
   Begin VB.CommandButton Command8 
      Caption         =   "数量分类图(ClassBreaksRenderer)"
      Height          =   375
      Left            =   5760
      TabIndex        =   4
      Top             =   2040
      Width           =   3015
   End
   Begin VB.CommandButton Command7 
      Caption         =   "全图显示"
      Height          =   375
      Left            =   5760
      TabIndex        =   7
      Top             =   3960
      Width           =   3015
   End
   Begin VB.CommandButton Command6 
      Caption         =   "文本标注图(LabelRenderer)"
      Height          =   375
      Left            =   5760
      TabIndex        =   6
      Top             =   3000
      Width           =   3015
   End
   Begin VB.CommandButton Command5 
      Caption         =   "渐变符号图(ClassBreaksRenderer)"
      Height          =   375
      Left            =   5760
      TabIndex        =   5
      Top             =   2520
      Width           =   3015
   End
   Begin VB.CommandButton Command4 
      Caption         =   "标准差图(ClassBreaksRenderer)"
      Height          =   375
      Left            =   5760
      TabIndex        =   3
      Top             =   1560
      Width           =   3015
   End
   Begin VB.CommandButton Command3 
      Caption         =   "唯一值图(ValueMapRenderer)"
      Height          =   375
      Left            =   5760
      TabIndex        =   2
      Top             =   1080
      Width           =   3015
   End
   Begin VB.CommandButton Command2 
      Caption         =   "单一符号"
      Height          =   375
      Left            =   5760
      TabIndex        =   0
      Top             =   120
      Width           =   3015
   End
   Begin VB.CommandButton Command1 
      Caption         =   "点密度图(DotDensityRenderer)"
      Height          =   375
      Left            =   5760
      TabIndex        =   1
      Top             =   600
      Width           =   3015
   End
   Begin MapObjects2.Map Map1 
      Height          =   4815
      Left            =   120
      TabIndex        =   8
      Top             =   0
      Width           =   5535
      _Version        =   131072
      _ExtentX        =   9763
      _ExtentY        =   8493
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "ThematicMap.frx":0000
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'点密度图(DotDensityRenderer)按钮鼠标单击事件响应代码
Private Sub Command1_Click()
  Screen.MousePointer = vbHourglass
  '隐藏NeCenter层
  Map1.Layers("NeCenter").Visible = False  ' hide NeCenter
  
  Set ly = Map1.Layers("Counties")
  '建立新的DotDensityRenderer对象
  Set ly.Renderer = New DotDensityRenderer
  '设置所依据的字段
  ly.Renderer.Field = "HBEDS_1000"
  '下面代码通过"HBEDS_1000"字段值计算点数
  '获取"HBEDS_1000"字段统计数据
  Set stats = ly.Records.CalculateStatistics("HBEDS_1000")
  '以统计数据为基础计算点数
  ly.Renderer.DotValue = (stats.Min + (stats.Max - stats.Min) / 2) / 20
  '刷新Map Control中地图
  Map1.Refresh

  Screen.MousePointer = vbDefault
End Sub

Private Sub Command2_Click()
  Screen.MousePointer = vbHourglass
  
  Map1.Layers("NeCenter").Visible = False  ' hide NeCenter
  
  Set Map1.Layers("Counties").Renderer = Nothing
  Map1.Refresh

  Screen.MousePointer = vbDefault
End Sub

Private Sub Command3_Click()
  Screen.MousePointer = vbHourglass
  
  Map1.Layers("NeCenter").Visible = False  ' hide NeCenter
  
  ' find unique values for STATE_NAME field
  Dim strings As New MapObjects2.strings
  Set ly = Map1.Layers("Counties")
  Set recs = ly.Records
  Do While Not recs.EOF
    strings.Add recs("STATE_NAME").Value
    recs.MoveNext
  Loop
  
  Set ly.Renderer = New ValueMapRenderer
  ly.Renderer.Field = "STATE_NAME"
  
  ' add the unique values to the renderer
  ly.Renderer.ValueCount = strings.Count
  For i = 0 To strings.Count - 1
    ly.Renderer.Value(i) = strings(i)
  Next i
  
  Map1.Refresh

  Screen.MousePointer = vbDefault
End Sub

Private Sub Command4_Click()
  Screen.MousePointer = vbHourglass
  
  Map1.Layers("NeCenter").Visible = False  ' hide NeCenter
  
  Set ly = Map1.Layers("Counties")
  Set ly.Renderer = New ClassBreaksRenderer
  Set r = ly.Renderer
  
  r.Field = "P_OTHER"
  Set stats = ly.Records.CalculateStatistics("P_OTHER")
  
  ' calculate breaks away from the mean in both directions,
  ' but only add those breaks that are within the range of values
  
  Dim breakVal As Double
  breakVal = stats.Mean - (stats.StdDev * 3)
  For i = 0 To 6
    If breakVal >= stats.Min And breakVal <= stats.Max Then
      r.BreakCount = r.BreakCount + 1
      r.Break(r.BreakCount - 1) = breakVal
    End If
    breakVal = breakVal + stats.StdDev
  Next i
  
  ' create a color ramp
  r.RampColors moLightYellow, moBlue
  Map1.Refresh

  Screen.MousePointer = vbDefault
End Sub

'渐变符号图(ClassBreaksRenderer)按钮鼠标单击事件响应代码
Private Sub Command5_Click()
  Screen.MousePointer = vbHourglass
  '显示NeCenter层
  Map1.Layers("NeCenter").Visible = True
  '清除Counties层上已有的其他Renderer
  Set Map1.Layers("Counties").Renderer = Nothing
   
  Set ly = Map1.Layers("NeCenter")
  '建立新的ClassBreaksRenderer对象
  Set ly.Renderer = New ClassBreaksRenderer
  Set r = ly.Renderer
  '设置着色所依据的字段
  r.Field = "P_OTHER"
  r.SymbolType = ly.Symbol.SymbolType
  '设置统计对象
  Set stats = ly.Records.CalculateStatistics("P_OTHER")
  '以字段P_OTHER的标准差为区间长度
  '在P_OTHER字段的平均值附近生成7个区间
  Dim breakVal As Double
  breakVal = stats.Mean - (stats.StdDev * 3)
  For i = 0 To 6
    If breakVal >= stats.Min And breakVal <= stats.Max Then
      r.BreakCount = r.BreakCount + 1
      '设置区间分界点
      r.Break(r.BreakCount - 1) = breakVal
    End If
    breakVal = breakVal + stats.StdDev
  Next i
  '使用SizeSymbols方法改变区间序列的符号大小
  r.SizeSymbols 3, 8
  '将所有区间的颜色变成红色
  For i = 0 To r.BreakCount
    r.Symbol(i).Color = moRed
  Next i
  '刷新Map Control中地图
  Map1.Refresh

  Screen.MousePointer = vbDefault
End Sub


Private Sub Command6_Click()
  Screen.MousePointer = vbHourglass
  
  Map1.Layers("NeCenter").Visible = False  ' hide NeCenter
  
  Dim f As New StdFont
  f.Name = "Times"
  f.Bold = False
  
  Set ly = Map1.Layers("Counties")
  Set ly.Renderer = New LabelRenderer
  ly.Renderer.Symbol(0).Height = 12000
  Set ly.Renderer.Symbol(0).Font = f
  ly.Renderer.Field = "cnty_name"
  ly.Renderer.AllowDuplicates = True
  Map1.Refresh

  Screen.MousePointer = vbDefault
End Sub

Private Sub Command7_Click()
  Map1.Extent = Map1.FullExtent
End Sub

Private Sub Command8_Click()
  Screen.MousePointer = vbHourglass
  
  Map1.Layers("NeCenter").Visible = False  ' hide NeCenter
  
  Set ly = Map1.Layers("Counties")
  Set ly.Renderer = New ClassBreaksRenderer
  Set r = ly.Renderer
  
  nClasses = 5
  nRecs = ly.Records.Count
  r.BreakCount = nClasses - 1
  r.Field = "P_OTHER"

  ' query all the features and order the results
  Set recs = ly.SearchExpression("FeatureId > -1 order by P_OTHER")
  
  ' navigate the record set and set up the breaks
  For i = 0 To r.BreakCount - 1
    For j = 1 To nRecs / nClasses
      recs.MoveNext
    Next j
    r.Break(i) = recs("P_OTHER").Value
  Next i
  
  ' create a color ramp
  r.RampColors moLightYellow, moBlue
  Map1.Refresh

  Screen.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
  '打开MapLayer图层，并将其添加到Map Control
  '这里使用的是MapObjects自带的NorthEast地图数据
  Dim dc As New DataConnection
  dc.Database = "C:\Program Files\ESRI\MapObjects2\Samples\Data\NorthEast"
    If Not dc.Connect Then End
  
  Dim layer As MapLayer
  Set layer = New MapLayer
  Set layer.GeoDataset = dc.FindGeoDataset("Counties")
  layer.Symbol.Color = RGB(0, 0, 250)
  Map1.Layers.Add layer

  Set layer = New MapLayer
  Set layer.GeoDataset = dc.FindGeoDataset("NeCenter")
  layer.Visible = False
  Map1.Layers.Add layer
  
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Button = 1 Then
    '鼠标左键被按下
    '开始放大操作
    Set r = Map1.TrackRectangle
    If Not r Is Nothing Then Map1.Extent = r
  Else
    '鼠标右键被按下
    '开始缩小操作
    Set r = Map1.Extent
    r.ScaleRectangle 1.5
    Map1.Extent = r
  End If
End Sub