form1.frm

mo2.4+vb开发的一个小的地理信息系统

Private Sub mun_layer_tracking_moving_Click()
 '动态演示动态图层
If Timertracking.Interval Then
Timertracking.Interval = 0
Else
Timertracking.Interval = 500
End If

End Sub

Private Sub mun_layer_tracking_removeevent_Click()
 '移出动态图层中的事件
  If Map1.TrackingLayer.EventCount > 0 Then
    Map1.TrackingLayer.RemoveEvent 0
  End If
End Sub

Private Sub mun_layer_tracking_selecevent_Click()
  '选择动态图层中的事件
 flag = 9
 Map1.MousePointer = moArrow
 End Sub

Private Sub mun_query_place_Click()
 '查询位置，有属性
Dim shp As Object

Dim recs As MapObjects2.Recordset
If strcondition <> "" Then
Set recs = lar.SearchExpression(strcondition)

Set shp = recs("Shape").Value
Set Map1.Extent = shp.Extent
Map1.Refresh
Map1.FlashShape shp, 4
End If
End Sub

Private Sub mun_query_shuxin_Click()
 '检索属性 加载frmconditionquery窗体 并显示
Load frmconditionquery
frmconditionquery.Show
End Sub

Private Sub mun_query_value_Click()
 '由位置查询属性 并设标志 flag为四
flag = 4
Map1.MousePointer = moArrowQuestion
End Sub

Private Sub mun_view_butter_dot_Click()
 '点缓冲 设标志flag为为五
flag = 5
Map1.MousePointer = moCross
End Sub

Private Sub mun_view_butter_line_Click()
 '线缓冲 ，实质标志flag为六
flag = 6
Map1.MousePointer = moCross

End Sub

Private Sub mun_view_butter_poligen_Click()
 '面缓冲，并设标志为七
flag = 7
Map1.MousePointer = moCross

End Sub

Private Sub mun_view_chart_Click()
 'chart渲染
myrender (5)
End Sub

Private Sub mun_view_class_Click()
 '类渲染
myrender (1)
End Sub

Private Sub mun_view_dot_Click()
 '点渲染
myrender (3)
End Sub

Private Sub mun_view_label_Click()
 '标注渲染
myrender (4)
End Sub

Private Sub mun_view_statebar_Click()
 '设置状态条是否可见
If StsBar1.Visible Then
StsBar1.Visible = 0
Else
StsBar1.Visible = 1
End If


End Sub

Private Sub mun_view_value_Click()
 '按值渲染
myrender (2)
End Sub

Public Sub myrender(typerender As Integer)  '定义了一个渲染的过程 包括了各种渲染类型

'/****************** 1 类渲染  class renderer ******************//
Dim oclassrnd As New MapObjects2.ClassBreaksRenderer    '定义类渲染对象
Dim ostats As New MapObjects2.Statistics    '定义统计变量
Dim i As Integer     '定义一个变量
Dim fbreak As Double  '定义类的断点值变量

'//****************** 2 值渲染 value ********************
Dim sfiledname As String            '定义字符串变量
Dim strs As New MapObjects2.Strings   '定义一个字符串组 变量
Dim valuerend As New MapObjects2.ValueMapRenderer  '定义值渲染对象

'//****************** 3 点渲染 dot ************************/
Dim dotrend As New MapObjects2.DotDensityRenderer  '定 点渲染对象
 
'//******************** 4 标注渲染  label renderer ****************/

Dim lblrend As New MapObjects2.LabelRenderer  '定义标注渲染对象
Dim sbol As New MapObjects2.TextSymbol  '定义一个字符类型的符号标量

'//****************** 5 图表渲染 chart *************************/

Dim chartrend As New MapObjects2.ChartRenderer   '定义一个图表渲染对象
'/*******************
On Error Resume Next
 '设置渲染层
Set lar = Map1.Layers(0)
Set recs = lar.Records
 '开始渲染

Select Case typerender

Case 1
    If Not lar.Records.Fields(list1.Text).Type = moString Then  '类渲染要是数值型的
   With oclassrnd
    .SymbolType = moFillSymbol              ' 设置 符号的类型
    .Field = list1.Text           '设置用到的字段
    Set ostats = Map1.Layers(0).Records.CalculateStatistics(list1.Text)  '统计当前字断的值
    fbreak = ostats.Mean - (ostats.StdDev * 3)
'    Print ostats.StdDev
'    Print ostats.Sum
    For i = o To 6 Step 1  '设置类对象的短点值 和 类的数目
    If fbreak >= ostats.Min And fbreak <= ostats.Max Then
    .BreakCount = .BreakCount + 1
    .Break(.BreakCount - 1) = fbreak
    End If
    fbreak = fbreak + ostats.StdDev
    Next
    .RampColors moYellow, moBlue
    Set lar.Renderer = oclassrnd      '设置当前图层的渲染
    End With
Else
     MsgBox "请选择一个数字类型的字断 " '当只段不是数字时，提示框
    End If

Case 2

    sfiledname = list1.Text
strs.Unique = True
Do While Not recs.EOF        '将当前的图层的莫移字段值取出 给 strs这个字符串组
 strs.Add recs(sfiledname).ValueAsString
 recs.MoveNext
Loop
With valuerend    '设置值渲染的选关属性 field和valuecount
 .Field = sfiledname
 .ValueCount = strs.Count
 
 i = 0
 For Each vstr In strs  ' 为每个 value 副值
     .Value(i) = vstr
     i = i + 1
Next
End With
Set lar.Renderer = valuerend

Case 3
 
    With dotrend             '设置属性
         .Field = list1.Text         '设置关联字段
         .DotSize = 4                '点的大小
         .DotColor = moRed        '点的颜色
         .DotValue = 10
         
         .DrawBackground = True     '重型绘背景图层
End With
Set lar = Map1.Layers(0)
lar.Symbol.Color = moPaleYellow
lar.Renderer = dotrend
 

Case 4
    With sbol  '设置符号属性
.Color = moBlue
 
.Rotation = 5
End With
 
With lblrend '设置属性
 .Field = list1.Text '设置关联字段
 .LevelField = list1.Text  '设置关联字段
 .DrawBackground = True '重型绘背景图层
 .SplinedText = True
 .Symbol(0).Color = moBlue
 End With
 lar.Symbol.Color = moLightYellow
 Set lar.Renderer = lblrend     '渲染当前图层

 
 Case 5
     With chartrend '设置属性
 .ChartType = moPie

 .FieldCount = 2 '设置关联字段数目
 .Field(0) = "AREA" '设置关联字段
 .Field(1) = "FeatureId" '设置关联字段
 .Color(0) = moYellow
 .Color(1) = moBlue
 '设置图的最大于最
 .MaxPieSize = 20
 .MinPieSize = 10
 .DrawBackground = True '重型绘背景图层
 End With
Set lar.Renderer = chartrend  '渲染当前图层
End Select
Set lar = Nothing
'设置图例
Map1.Refresh
'加载图例
legend1.setMapSource Map1
legend1.LoadLegend True
End Sub

Private Sub Timer1_Timer()
   
StsBar1.Panels(2).Width = 1000
StsBar1.Panels(2).Text = Time$
End Sub

Private Sub Timertracking_Timer()
'用于动态图层产生事件
  maxDist = Map1.Extent.Width / 20
  
  nEventCount = Map1.TrackingLayer.EventCount
  For iIndex = 0 To nEventCount - 1
    Set gEvt = Map1.TrackingLayer.Event(iIndex)
    gEvt.Move maxDist * (Rnd - 0.5), maxDist * (Rnd - 0.5)
  Next iIndex
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim mapwidth As Double
Dim mapheight As Double
Dim loc As New MapObjects2.Point
 '根据单击toolbar1上的按钮不通，设置个个标志 和  鼠标类型
Select Case Button.Key
Case "tbarzoomin"
   flag = 1
   Map1.MousePointer = moZoomIn
Case "tbarzoomout"
  flag = 2
  Map1.MousePointer = moZoomOut
Case "tbarpan"
  flag = 3
  Map1.MousePointer = moPan
Case "tbarquery"
  flag = 4
Map1.MousePointer = moArrowQuestion
Case "exitarrow"
Map1.MousePointer = moArrow
End Select

End Sub

Public Function layercolor(i As Integer) As MapObjects2.Symbol
'用于产生图层时 给不通的颜色
Dim syn As New MapObjects2.Symbol
Select Case i
Case 1
   syn.Color = moGreen
   Set layercolor = syn
Case 2
   syn.Color = moBlue
   Set layercolor = syn
Case 3
   syn.Color = moRed
   Set layercolor = syn
Case 4
   syn.Color = moYellow
   Set layercolor = syn
Case 5
   syn.Color = moCyan
  Set layercolor = syn
Case 6
  syn.Color = moDarkGreen
 Set layercolor = syn
End Select


End Function

Public Sub set_legend1() '设置图例图源 并加载
legend1.setMapSource Map1
legend1.LoadLegend True
End Sub

Public Sub begingtrackLar()
  '将动态图层中的2种符号属性搞定，
  Dim fnt As New StdFont
  fnt.Name = "Wingdings"
  fnt.Bold = False
  Map1.TrackingLayer.SymbolCount = 2
  '第1个 颜色，大小，字体 啊
  Map1.TrackingLayer.Symbol(0).Color = moBlue
  Map1.TrackingLayer.Symbol(0).Style = moTrueTypeMarker
  Map1.TrackingLayer.Symbol(0).Font = fnt
  Map1.TrackingLayer.Symbol(0).Size = 16
  Map1.TrackingLayer.Symbol(0).CharacterIndex = 88
  '第2个  颜色，大小，字体 啊
  Map1.TrackingLayer.Symbol(1).Color = moDarkGreen
  Map1.TrackingLayer.Symbol(1).Style = moTrueTypeMarker
  Map1.TrackingLayer.Symbol(1).Font = fnt
  Map1.TrackingLayer.Symbol(1).Size = 16
  Map1.TrackingLayer.Symbol(1).CharacterIndex = 88
End Sub

Public Sub AddEvent(x As Single, y As Single)
' convert the point to map coordinates
  Set pt = Map1.ToMapPoint(x, y)
  ' add a new event
  Map1.TrackingLayer.AddEvent pt, sym
End Sub

Public Sub slectevent()
  '选择 一个事件的过程
  Set rcg = Map1.TrackRectangle '获取 追丛矩形
  nEventCount = Map1.TrackingLayer.EventCount '的到动态图层中的事件的数目
  Dim testPt As New Point
  For i = 0 To nEventCount - 1  '查找矩形框中是否由事件 由的哈，就吧事件的颜色变以下 啊啊
    Set evt = Map1.TrackingLayer.Event(i)
    testPt.x = evt.x
    testPt.y = evt.y
    If rcg.IsPointIn(testPt) Then
      evt.SymbolIndex = 1
    Else
      evt.SymbolIndex = 0
    End If
  Next i
 
End Sub