identify.frm

这个是grs源程序,mo在图象显示上很好,所以大家一定要下载

VERSION 5.00
Begin VB.Form frmIdentify 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Identify Results"
   ClientHeight    =   5805
   ClientLeft      =   810
   ClientTop       =   735
   ClientWidth     =   2805
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   5805
   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          =   3375
      Left            =   120
      TabIndex        =   4
      Top             =   1560
      Width           =   2535
   End
   Begin VB.Label lblShapeType 
      Caption         =   "Shape Type:"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   5520
      Width           =   3135
   End
   Begin VB.Label lblTheme 
      Caption         =   "Theme:"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   5280
      Width           =   3195
   End
   Begin VB.Label lblAttributes 
      Caption         =   "Attributes:"
      Height          =   255
      Left            =   120
      TabIndex        =   3
      Top             =   1320
      Width           =   855
   End
   Begin VB.Label lblFeature 
      Caption         =   "Feature:"
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   600
      Width           =   735
   End
   Begin VB.Label lblFeatFound 
      Caption         =   "0 features found"
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   300
      Width           =   2055
   End
   Begin VB.Label lblLocation 
      Caption         =   "Location:"
      Height          =   195
      Left            =   120
      TabIndex        =   0
      Top             =   60
      Width           =   3435
   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 Point
Dim Recs2() As MapObjects2.Recordset
Dim layerName() As String
Dim layerNum() As Long
'
'THIS FORM IDENTIFIES THE FEATURES WITHIN ALL
'LAYERS WITHIN 3 SCREEN PIXELS OF THE MOUSE
'CLICK.  ALL LAYERS, NOT JUST THE ACTIVE LAYER.

Sub Identify(x As Single, y As Single)
  'This routine takes the X and Y position from the MouseDown event
  'finds the features which are at or near that point, and populates
  'the Identify form.
  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
  
  layer_c = frmMain.mapDisp.Layers.count
  ReDim layerName(layer_c)
  ReDim Recs2(layer_c)
  
  Screen.MousePointer = 11
  'Get identify lblLocation.
  cboIDList.Clear
  lstFeatList.Clear
  lblFeatFound.Caption = "Searching . . ."
  lblTheme.Caption = "Theme:"
  lblShapeType.Caption = "Shape:"
  Set Loc = frmMain.mapDisp.ToMapPoint(x, y)
  Dim xStr As String, yStr As String
  'If coordinates are lat-longs, we don't want to truncate,
  'but if they are greater, we only want to show the integer values.
  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 = "Location:  (" & xStr & "," + yStr + ")"
  featCount = 0
  layerCount = -1
  'Set the tolerance:
  theTol = frmMain.mapDisp.ToMapDistance(SEARCHTOLPIXELS * Screen.TwipsPerPixelX)
  
  'Loop through layers performing query on each.
  For Each aLayer In frmMain.mapDisp.Layers
    If aLayer.Visible And aLayer.LayerType = moMapLayer Then
      Set recs = aLayer.SearchByDistance(Loc, theTol, "")
      'Loop through selected features and store pointers.
      layerCount = layerCount + 1
      layerName(layerCount) = aLayer.Name
      Set Recs2(layerCount) = recs
      curCount = -1
      If recs.count <> 0 Then
        aName = "Featureid"
        'Determine main string (or ID) field to list.
        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
        theItem = recs(aName).ValueAsString
        If theItem = "" Then
          cboIDList.AddItem recs("FeatureId").ValueAsString
        Else
          cboIDList.AddItem theItem
        End If
        recs.MoveNext
      Wend
    End If
  Next aLayer
  
  'Set feature count label.
  Visible = True
  If featCount = 1 Then
    lblFeatFound.Caption = "1 feature found"
  Else
    lblFeatFound.Caption = str(featCount) + " features found"
  End If
  
  'Exit sub if no features were found.
  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
'
' Determine selected item from list.
'
  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 variable to the correct record.
'
  Set curRec = Recs2(aIndex)
  curRec.MoveFirst
  If aRec > 0 Then
    For i = 1 To aRec
      curRec.MoveNext
    Next i
  End If
'
' Flash the selected feature.
'
  frmMain.mapDisp.FlashShape curRec("shape").Value, 3
'
' List the attribute values for the selected feature.
'
  lblTheme.Caption = "Theme:  " + 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 = "Shape Type:  Point"
    Case moLine
      lblShapeType.Caption = "Shape Type:  Line"
    Case moPolygon
      lblShapeType.Caption = "Shape Type:  Polygon"
    Case Else
      lstFeatList.AddItem aField.Name + " = " + aField.ValueAsString
    End Select
  Next aField

End Sub

Private Sub cboIDList_Click()
  Identify_list
End Sub

Private Sub Form_Load()

'Position to the right of the main form
Me.Move frmMain.Left + frmMain.Width, frmMain.Top
If (Me.Left + Me.Width) > Screen.Width Then
  Me.Left = Screen.Width - Me.Width
End If

End Sub