form1.frm

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

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form Form1 
   Caption         =   "EventRenderer示例"
   ClientHeight    =   5835
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6720
   LinkTopic       =   "Form3"
   ScaleHeight     =   5835
   ScaleWidth      =   6720
   StartUpPosition =   3  '窗口缺省
   Begin ComctlLib.StatusBar StatusBar1 
      Align           =   2  'Align Bottom
      Height          =   375
      Left            =   0
      TabIndex        =   5
      Top             =   5460
      Width           =   6720
      _ExtentX        =   11853
      _ExtentY        =   661
      Style           =   1
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 
         NumPanels       =   1
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            Key             =   ""
            Object.Tag             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.CommandButton cmdLineER 
      Caption         =   "添加线状事件"
      Height          =   375
      Left            =   120
      TabIndex        =   4
      Top             =   5040
      Width           =   1575
   End
   Begin VB.CheckBox chkIndex 
      Caption         =   "建立索引"
      Height          =   375
      Left            =   3480
      TabIndex        =   3
      Top             =   5040
      Value           =   1  'Checked
      Width           =   1455
   End
   Begin VB.CommandButton cmdFullExtent 
      Caption         =   "全图显示"
      Height          =   375
      Left            =   5040
      TabIndex        =   2
      Top             =   5040
      Width           =   1575
   End
   Begin VB.CommandButton cmdPointER 
      Caption         =   "添加点状事件"
      Height          =   375
      Left            =   1800
      TabIndex        =   1
      Top             =   5040
      Width           =   1575
   End
   Begin MapObjects2.Map Map1 
      Height          =   4815
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   6495
      _Version        =   131072
      _ExtentX        =   11456
      _ExtentY        =   8493
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "Form1.frx":0000
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'FEATURE_FILE为存储线型地理对象的图层
Const FEATURE_FILE As String = "highway.shp"
'POINT_TABLE为生成点状事件的数据表
Const POINT_TABLE As String = "accident"
'LINEAR_TABLE为生成线状事件的数据表
Const LINEAR_TABLE As String = "pavement"
Const INSTRUCTIONS As String = "鼠标右键单击事件以高亮显示它"

Dim dConn As MapObjects2.DataConnection
Dim strPath As String

Private Sub ConnectDatabase(strDataFolder As String)
  ' 初始化DataConnection对象
  If dConn Is Nothing Then
      Set dConn = New MapObjects2.DataConnection
  End If
  '设置DataConnection
  dConn.Database = strDataFolder
    
  If Not dConn.Connect Then
    MsgBox "无法连接地理数据库:" & strDataFolder, vbCritical, Me.Caption
    Stop
  End If
End Sub

Private Sub AddLayer(strDatasetName As String)
  Dim mLayer As New MapObjects2.MapLayer
  '建立新图层,读入数据
  If dConn.FindGeoDataset(strDatasetName) Is Nothing Then
    MsgBox "无法找到图层:" & strDatasetName, vbExclamation, Me.Caption
    Exit Sub
  Else
    Set mLayer.GeoDataset = dConn.FindGeoDataset(strDatasetName)
    Map1.Layers.Add mLayer
  End If
End Sub

Private Sub chkIndex_Click()
  '是否为事件建立索引
  Dim lyr As MapObjects2.MapLayer
  
  Set lyr = Map1.Layers(FEATURE_FILE)
  If Not lyr.Renderer Is Nothing Then
    lyr.Renderer.IndexEvents = (chkIndex.Value = vbChecked)
  End If
End Sub

Private Sub cmdFullExtent_Click()
  ' 将地图当前显示范围设置为全图
  Set Map1.Extent = Map1.FullExtent
End Sub

Private Sub cmdLineER_Click()
  '建立一个EventRednerer以显示线状事件
  
  Dim lyr As MapObjects2.MapLayer
  Dim evrend As MapObjects2.EventRenderer
  Dim tbl As New MapObjects2.Table
  
  '锁定窗体
  Form1.MousePointer = vbHourglass
  Form1.Enabled = False
  
  Set lyr = Map1.Layers(FEATURE_FILE)
  '读入EventTable，对于大型的EventTable，可以使用ODBC数据源以提高性能
  tbl.Database = "dbase iv; database=" & dConn.Database
  tbl.Name = LINEAR_TABLE

  Set evrend = New MapObjects2.EventRenderer
  
  '设置EventRenderer属性
  With evrend
    .SymbolType = moLineSymbol
    If chkIndex = vbChecked Then
      '在EventRenderer被赋值给MapLayer前指定IndexEvents为True
      '则索引将被提前建立,这将会消耗一定时间
      .IndexEvents = True
      
      '检查当前显示范围是否包含了整个需要生成事件的图层
      If (Map1.Extent.Width < lyr.Extent.Width) Or _
        (Map1.Extent.Height < lyr.Extent.Height) Then
        If MsgBox("只为当前显示的事件建立索引吗?", _
                  vbYesNo, Me.Caption) = vbYes Then
          '设置IndexExtent为当前地图显示范围
          .IndexExtent = Map1.Extent
        End If
      End If
    End If
    Set .EventTable = tbl
    
    '设置事件与地理对象同时被显示
    .DrawBackground = True
    
    '设置路由ID字段等
    .FeatureRouteIDField = "rkey"
    .EventRouteIDField = "rkey"
    .StartMeasureField = "fmp"
    .EndMeasureField = "tmp"
    .SymbolField = "rideq"
    
    '这里演示不用SymbolField,手动设置Symbol属性
    .ValueCount = 3
    .Value(0) = "L"
    .Symbol(0).Style = moSolidLine
    .Symbol(0).Size = 2
    .Symbol(0).Color = GetNewColour
    .Value(1) = "M"
    .Symbol(1).Style = moSolidLine
    .Symbol(1).Size = 2
    .Symbol(1).Color = GetNewColour
    .Value(2) = "N"
    .Symbol(2).Style = moSolidLine
    .Symbol(2).Size = 2
    .Symbol(2).Color = GetNewColour
  End With

  If evrend.IndexEvents Then
    StatusBar1.SimpleText = "请稍候,正在为事件建立索引..."
    StatusBar1.Refresh
  End If
  
  Set lyr.Renderer = evrend
  
  '激活窗体
  Form1.MousePointer = vbNormal
  Form1.Enabled = True
  StatusBar1.SimpleText = "Event Renderer设置完成"
  
  '检查是否需要刷新地图
  '由于为大量事件建立索引速度较慢,
  '有时在设置好EventRenderer后并不刷新地图
  If MsgBox("是否现在刷新地图?", vbYesNo, Me.Caption) = vbYes Then
    Map1.Refresh
  Else
    StatusBar1.SimpleText = INSTRUCTIONS
  End If
End Sub

Private Sub cmdPointER_Click()
  '建立一个EventRednerer以显示线状事件
  
  Dim lyr As MapObjects2.MapLayer
  Dim tbl As New MapObjects2.Table
  
  '锁定窗体
  Form1.MousePointer = vbHourglass
  Form1.Enabled = False
  
  Set lyr = Map1.Layers(FEATURE_FILE)
  
  '读入EventTable，对于大型的EventTable，可以使用ODBC数据源以提高性能
  tbl.Database = "dbase iv; database=" & dConn.Database
  tbl.Name = POINT_TABLE

  Dim evrend As New MapObjects2.EventRenderer
  
  '设置EventRenderer属性
  With evrend
    .SymbolType = moPointSymbol
    If chkIndex = vbChecked Then
      '在EventRenderer被赋值给MapLayer前指定IndexEvents为True
      '则索引将被提前建立,这将会消耗一定时间
      .IndexEvents = True
      
      '检查当前显示范围是否包含了整个需要生成事件的图层
      If (Map1.Extent.Width < lyr.Extent.Width) Or _
          (Map1.Extent.Height < lyr.Extent.Height) Then
        If MsgBox("只为当前显示的事件建立索引吗?", _
                  vbYesNo, Me.Caption) = vbYes Then
          '设置IndexExtent为当前地图显示范围
          .IndexExtent = Map1.Extent
        End If
      End If
    End If
    Set .EventTable = tbl
    
    '设置事件与地理对象同时被显示
    .DrawBackground = True
    
    '此处设置DefaultSymbol，所有点状事件均以此方式显示
    .DefaultSymbol.SymbolType = moPointSymbol
    .DefaultSymbol.Style = moCircleMarker
    .DefaultSymbol.Color = moRed
    .DefaultSymbol.Size = 4
    .UseDefault = True
    
    '设置路由ID字段等
    .FeatureRouteIDField = "rkey"
    .EventRouteIDField = "rkey"
    .StartMeasureField = "mile"
  End With

  If evrend.IndexEvents Then
    StatusBar1.SimpleText = "请稍候,正在为事件建立索引..."
    StatusBar1.Refresh
  End If
  
  Set lyr.Renderer = evrend
  
  '激活窗体
  Form1.MousePointer = vbNormal
  Form1.Enabled = True
  StatusBar1.SimpleText = "Event Renderer设置完成"
  
  '检查是否需要刷新地图
  '由于为大量事件建立索引速度较慢,
  '有时在设置好EventRenderer后并不刷新地图
  If MsgBox("是否现在刷新地图?", vbYesNo, Me.Caption) = vbYes Then
    Map1.Refresh
  Else
    StatusBar1.SimpleText = INSTRUCTIONS
  End If
End Sub

Private Sub Form_Load()
  ' 连接数据库
  Dim dir_path As String
  dir_path = "C:\Program Files\ESRI\MapObjects2\Samples\Data\Events"
  Call ConnectDatabase(dir_path)
  
  '读入图层
  Call AddLayer(FEATURE_FILE)
  StatusBar1.SimpleText = "已读入:" & FEATURE_FILE
End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)
  '恢复窗体和鼠标指针
  Form1.Enabled = True
  Form1.MousePointer = vbNormal
  StatusBar1.SimpleText = INSTRUCTIONS
End Sub

Private Sub Map1_BeforeLayerDraw(ByVal index As Integer, _
                                  ByVal hDC As stdole.OLE_HANDLE)
    
  '显示大量事件将耗费一定时间
  '因此需要暂时使窗体无效,并改变鼠标指针
  If index = Map1.Layers.Count - 1 Then
    Form1.Enabled = False
    Form1.MousePointer = vbHourglass
  End If
  If Not Map1.Layers(index).Renderer Is Nothing Then
    StatusBar1.SimpleText = "正在显示事件,请稍候..."
    StatusBar1.Refresh
  End If
End Sub

Private Sub Map1_DrawingCanceled()
    
  '恢复窗体和鼠标指针
  Form1.Enabled = True
  Form1.MousePointer = vbNormal
  StatusBar1.SimpleText = INSTRUCTIONS
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, _
                            X As Single, Y As Single)
    
  '响应鼠标事件
  If Button = vbLeftButton Then
    '放大
    Set Map1.Extent = Map1.TrackRectangle
  ElseIf Button = vbRightButton Then
    '搜索并高亮显示最近的事件
    
    '获取MapLayer
    Dim lyr As MapObjects2.MapLayer
    Set lyr = Map1.Layers(FEATURE_FILE)
    
    '检查MapLayer是否有EventRenderer对象
    Dim evr As MapObjects2.EventRenderer
    Set evr = lyr.Renderer
    If evr Is Nothing Then
      MsgBox "请将EventRenderer对象应用于当前图层上.", _
              vbExclamation, Me.Caption
      Exit Sub
    End If
    
    '将鼠标位置转换为地图上的点
    Dim pt As MapObjects2.Point
    Set pt = Map1.ToMapPoint(X, Y)
    
    '执行查询
    Dim shpEvent As Object
    If evr.EndMeasureField = "" Then
      Set shpEvent = CommonEventCode.ReturnClosestPointEvents( _
                      pt, lyr, Map1.Extent)
    Else
      Set shpEvent = CommonEventCode.ReturnClosestLinearEvent( _
                      pt, lyr, Map1.Extent)
    End If
    If shpEvent Is Nothing Then
        
      '高亮显示地理对象
      Dim feature As MapObjects2.Line
      Set feature = CommonEventCode.ReturnClosestLine( _
                    pt, lyr, "", "", Map1.Extent)
      If Not feature Is Nothing Then
        Map1.FlashShape feature, 2
        MsgBox "当前地理对象上并无任何事件", vbExclamation, Me.Caption
      Else
        MsgBox "未找到地理对象", vbExclamation, Me.Caption
      End If
      Exit Sub
    Else
      Map1.FlashShape shpEvent, 2
    End If
  End If
End Sub

Private Function GetNewColour() As Long
  '本函数每次返回不同的颜色
  Dim cols As Variant
  Dim col_val As Long
  Static i As Integer
  
  cols = Array(moBlack, moRed, moGreen, moBlue, moMagenta, moCyan, _
                moGray, moYellow, moTeal, moPurple, moOrange, moKhaki, moBrown)
  If i < UBound(cols) Then
      col_val = cols(i)
      i = i + 1
  Else
      col_val = cols(0)
      i = 1
  End If
  GetNewColour = col_val
  Set cols = Nothing
End Function