frmidentify.frm

给出了详细的vb环境下mo基本功能的代码 如图层的加载

VERSION 5.00
Begin VB.Form frmIdentify 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "属性查询结果"
   ClientHeight    =   4920
   ClientLeft      =   810
   ClientTop       =   735
   ClientWidth     =   2805
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4920
   ScaleWidth      =   2805
   ShowInTaskbar   =   0   'False
   Begin VB.ComboBox cboIDList 
      Height          =   315
      Left            =   120
      Style           =   2  'Dropdown List
      TabIndex        =   7
      Top             =   840
      Width           =   2535
   End
   Begin VB.ListBox lstFeatList 
      Height          =   2220
      Left            =   120
      TabIndex        =   4
      Top             =   1560
      Width           =   2535
   End
   Begin VB.Label lblShapeType 
      Caption         =   "形状:"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   4200
      Width           =   3135
   End
   Begin VB.Label lblTheme 
      Caption         =   "图层名:"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   3960
      Width           =   3195
   End
   Begin VB.Label lblAttributes 
      Caption         =   "属性数据："
      Height          =   255
      Left            =   240
      TabIndex        =   3
      Top             =   1320
      Width           =   1095
   End
   Begin VB.Label lblFeature 
      Caption         =   "对象名称："
      Height          =   255
      Left            =   240
      TabIndex        =   2
      Top             =   600
      Width           =   1095
   End
   Begin VB.Label lblFeatFound 
      Caption         =   "没有找到任何对象"
      Height          =   255
      Left            =   170
      TabIndex        =   1
      Top             =   300
      Width           =   2055
   End
   Begin VB.Label lblLocation 
      Caption         =   "位置"
      Height          =   435
      Left            =   120
      TabIndex        =   0
      Top             =   4440
      Width           =   2595
   End
End
Attribute VB_Name = "frmIdentify"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const SEARCHTOLPIXELS = 3
Dim Loc As New MapObjects2.Point
Dim Recs2() As MapObjects2.Recordset
Dim layerName() As String
Dim layerNum() As Long
Dim ThisForm As Form

'根据点击的坐标选择对象；
Sub Identify(X As Single, Y As Single)
  Dim curCount As Long, layerCount As Long, layer_c As Long
  Dim Loc As New MapObjects2.Point
  Dim theTol As Double
  Dim featCount As Long, fCount As Long
  Dim aLayer As Object
  Dim Recs As MapObjects2.Recordset
  Dim aName As String, theItem As String
  Dim aField As Object
  Dim xStr As String
  Dim yStr As String
  
  '设置参数；
  layer_c = ThisForm.Map1.Layers.Count
  ReDim layerName(layer_c)
  ReDim Recs2(layer_c)
  Screen.MousePointer = 11
  cboIDList.Clear
  lstFeatList.Clear
  
  '坐标处理；
  Set Loc = ThisForm.Map1.ToMapPoint(X, Y)
  If Loc.X > 1000 Or Loc.Y > 1000 Then
    xStr = Int(Loc.X)
    yStr = Int(Loc.Y)
  Else
    xStr = Loc.X: yStr = Loc.Y
  End If
  lblLocation.Caption = "位置:x=" & Int(xStr) & ",y=" & Int(yStr)
  featCount = 0
  layerCount = -1
  
  '设置误差；
  theTol = ThisForm.Map1.ToMapDistance(SEARCHTOLPIXELS * Screen.TwipsPerPixelX)
  
  '选择对象；
  For Each aLayer In ThisForm.Map1.Layers
    If aLayer.Visible And aLayer.LayerType = moMapLayer Then
      Set Recs = aLayer.SearchByDistance(Loc, theTol, "")
      layerCount = layerCount + 1
      layerName(layerCount) = aLayer.Name
      Set Recs2(layerCount) = Recs
      curCount = -1
      If Recs.Count <> 0 Then
        aName = "Featureid"
        For Each aField In Recs.Fields
          If aField.Type = moString Then
            aName = aField.Name
            Exit For
          End If
        Next
      End If
      While Not Recs.EOF
        ReDim Preserve layerNum(2, featCount + 1)
        curCount = curCount + 1
        layerNum(1, featCount) = layerCount
        layerNum(2, featCount) = curCount
        featCount = featCount + 1
        Select Case aLayer.Name
          Case "States": theItem = Recs("NAME").ValueAsString
          Case "Rivers": theItem = Recs("NAME").ValueAsString
          Case "Cities": theItem = Recs("NAME").ValueAsString
        End Select
        cboIDList.AddItem theItem
        Recs.MoveNext
      Wend
    End If
  Next aLayer
  
  Visible = True
  If featCount = 0 Then
    lblFeatFound.Caption = "没有找到任何对象"
  Else
    lblFeatFound.Caption = Str(featCount) + "个对象被找到"
  End If
  
  If featCount > 0 Then
    cboIDList.ListIndex = 0
    Call Identify_list
  End If
  Screen.MousePointer = 0
End Sub

'点击后显示属性；
Sub Identify_list()
  Dim curRec As MapObjects2.Recordset
  Dim curIndex As Long, aIndex As Long, aRec As Long, i As Long
  Dim aField As Object
  Dim aName As String
  
   '设置
  curIndex = cboIDList.ListIndex
  If IsNull(cboIDList.List(aIndex)) Then
    Exit Sub
  End If
  aIndex = layerNum(1, curIndex)
  aRec = layerNum(2, curIndex)
  aName = layerName(aIndex)
  Set curRec = Recs2(aIndex)
  curRec.MoveFirst
  If aRec > 0 Then
    For i = 1 To aRec
      curRec.MoveNext
    Next i
  End If
  
   '闪烁
  ThisForm.Map1.FlashShape curRec("shape").Value, 2
  
  '写属性；
  lblTheme.Caption = "图层名:  " + aName
  lstFeatList.Clear
  For Each aField In curRec.Fields
    Select Case aField.Type
    Case moString
      lstFeatList.AddItem aField.Name + " = " + aField.Value
    Case moPoint
      lblShapeType.Caption = "对象形状:  点"
    Case moLine
      lblShapeType.Caption = "对象形状:  线"
    Case moPolygon
      lblShapeType.Caption = "对象形状:  多边形"
    End Select
  Next aField
End Sub

'选择对象
Private Sub cboIDList_Click()
  Identify_list
End Sub

Private Sub Form_Load()
  Set ThisForm = Form06
  Me.Move ThisForm.Left + ThisForm.Width, ThisForm.Top
  If (Me.Left + Me.Width) > Screen.Width Then
    Me.Left = Screen.Width - Me.Width
  End If
  
  lblFeatFound.Caption = "查找 . . ."
  lblTheme.Caption = "图层名:"
  lblShapeType.Caption = "形状:"
End Sub