frmidentify.frm

用于河南省主体功能区区划的一个小地理信息系统

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form FrmIdentify 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "实体查询"
   ClientHeight    =   3600
   ClientLeft      =   5310
   ClientTop       =   3135
   ClientWidth     =   3765
   Icon            =   "Frmidentify.frx":0000
   LinkTopic       =   "Form3"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   3600
   ScaleWidth      =   3765
   ShowInTaskbar   =   0   'False
   Begin MSComctlLib.ListView ListView1 
      Height          =   3375
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   3495
      _ExtentX        =   6165
      _ExtentY        =   5953
      View            =   3
      LabelEdit       =   1
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      GridLines       =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
End
Attribute VB_Name = "FrmIdentify"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim recs As MapObjects2.Recordset

Sub Identify(X As Single, y As Single)
  'get the layer
  'Set g_ActiveLayer = Map1.Layers(legend1.getActiveLayer)
  Dim Index As Integer
  Index = frmmain.TuLi.getActiveLayer
  
  If Index = -1 Then
    MsgBox "当前没有活动图层。", vbCritical, "停止"
    Exit Sub
  End If
  
 ' Dim g_activelayer As Object
  Set g_activelayer = frmmain.Map1.Layers(Index)
  ' transform the point to map coordinates
  Set p = frmmain.Map1.ToMapPoint(X, y)
  
  ' perform the search
'  If g_activelayer.ShapeType = moPolygon Then
'    Set recs = g_activelayer.SearchShape(p, moPointInPolygon, "")
'  Else
    Set recs = g_activelayer.SearchByDistance(p, frmmain.Map1.ToMapDistance(100), "")
'  End If
   
     Dim desc As TableDesc
     Set desc = recs.TableDesc
  ' if the search returned something, display the fields
  ' and values
    
   If Not recs.EOF Then
    ' show the identify window
    frmmain.Map1.FlashShape recs.Fields("shape").Value, 3
    FrmIdentify.Show
    
    FrmIdentify.ListView1.ListItems.Clear
    Dim newitem As ListItem
    Set newitem = FrmIdentify.ListView1.ListItems.Add()
    newitem.Text = "FeatureId"
    newitem.SubItems(1) = recs("FeatureId").ValueAsString
    
 
    'Dim fld As MapObjects2.Field
    For i = 0 To desc.FieldCount - 1 ' iterate over the fields
      Set newitem = FrmIdentify.ListView1.ListItems.Add
      newitem.Text = desc.FieldName(i)
      newitem.SubItems(1) = recs(desc.FieldName(i)).ValueAsString  ' get the value
    Next i
  End If
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

  ' set up the columns of the listview control
  Set Col = ListView1.ColumnHeaders.Add()
  Col.Text = "Field"
  Col.Width = ListView1.Width / 2
  Set Col = ListView1.ColumnHeaders.Add()
  Col.Text = "Value"
  Col.Width = ListView1.Width / 2
  ListView1.LabelEdit = lvwManual
  ListView1.HideColumnHeaders = False
End Sub
'双击时闪烁现实对象
Private Sub ListView1_DblClick()
frmmain.Map1.FlashShape recs.Fields("shape").Value, 2
End Sub
Sub expressionidentify()
'  Dim Index As Integer
'  Index = frmmain.legend1.getActiveLayer
'
'  If Index = -1 Then
'    MsgBox "当前没有活动图层。", vbCritical, "停止"
'    Exit Sub
'  End If
  '获得活动图层
  Dim g_activelayer As MapObjects2.MapLayer
  Set g_activelayer = frmmain.Map1.Layers(attlyrname)
  ' If frmattidentify = True Then
  '获得选定记录集
       Dim s As String
       s = "FeatureId=" & identifytxt    'frmatt.lvwatt.SelectedItem.text
       Set recs = g_activelayer.SearchExpression(s)
'End If

     Dim desc As TableDesc
     Set desc = recs.TableDesc
  ' if the search returned something, display the fields
  ' and values

    ' show the identify window
    ' 填充listview1
    If Not recs.EOF Then
       FrmIdentify.ListView1.ListItems.Clear
       
    Dim newitem As ListItem
    Set newitem = FrmIdentify.ListView1.ListItems.Add()
    newitem.Text = "FeatureId"
    newitem.SubItems(1) = recs("FeatureId").ValueAsString

    'Dim fld As MapObjects2.Field
    For i = 0 To desc.FieldCount - 1 ' iterate over the fields
      Set newitem = FrmIdentify.ListView1.ListItems.Add()
      newitem.Text = desc.FieldName(i)
      newitem.SubItems(1) = recs(desc.FieldName(i)).ValueAsString  ' get the value
    Next i
    
     FrmIdentify.Show 1
  End If
End Sub