identify.frm

继续更新

VERSION 5.00
Begin VB.Form identify 
   Caption         =   "identify"
   ClientHeight    =   6855
   ClientLeft      =   60
   ClientTop       =   390
   ClientWidth     =   3240
   LinkTopic       =   "Form2"
   ScaleHeight     =   6855
   ScaleWidth      =   3240
   StartUpPosition =   3  '窗口缺省
   Begin VB.ListBox List1 
      Height          =   2760
      Left            =   240
      TabIndex        =   4
      Top             =   2040
      Width           =   2415
   End
   Begin VB.ComboBox Combo1 
      Height          =   300
      Left            =   240
      TabIndex        =   0
      Text            =   "Combo1"
      Top             =   1320
      Width           =   1935
   End
   Begin VB.Label Label6 
      Caption         =   "Label6"
      Height          =   375
      Left            =   240
      TabIndex        =   7
      Top             =   6240
      Width           =   2415
   End
   Begin VB.Label Label5 
      Caption         =   "Label5"
      Height          =   375
      Left            =   240
      TabIndex        =   6
      Top             =   5880
      Width           =   2175
   End
   Begin VB.Label Label4 
      Caption         =   "Label4"
      Height          =   375
      Left            =   240
      TabIndex        =   5
      Top             =   5400
      Width           =   2295
   End
   Begin VB.Label Label3 
      Caption         =   "Label3"
      Height          =   375
      Left            =   240
      TabIndex        =   3
      Top             =   4920
      Width           =   2535
   End
   Begin VB.Label Label2 
      Caption         =   "Label2"
      Height          =   375
      Left            =   240
      TabIndex        =   2
      Top             =   1680
      Width           =   1935
   End
   Begin VB.Label Label1 
      Caption         =   "Label1"
      Height          =   375
      Left            =   240
      TabIndex        =   1
      Top             =   840
      Width           =   1935
   End
End
Attribute VB_Name = "identify"
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

Private Sub Form_Load()
    Set thisform = Form1
    Me.Move thisform.Left + thisform.Width, thisform.Top
    If (Me.Left + Me.Width) > Screen.Width Then
       Me.Left = Screen.Width - Me.Width
    End If
    Label1.Caption = "对象名称"
    Label2.Caption = "属性 "
End Sub
Sub idty(x As Single, y As Single)   '查询函数
   Dim curcount As Long, layercount As Long, layer_c As Long  'curcount计数找到了几个对象
   Dim loc As New MapObjects2.Point   '实际坐标
   Dim xstr As String, ystr As String  'x\y坐标
   Dim wc As Double '误差
   Dim alayer As Object
   Dim recs As MapObjects2.Recordset
   Dim aname As String, theitem As String     ' 查找到的图层名为aname
   Dim afield As Object
   Dim featcount As Long, fcount As Long
   
   
   layer_c = thisform.Map1.Layers.Count
   ReDim layername(layer_c)
   ReDim recs2(layer_c)
   Screen.MousePointer = 11 '漏斗状
   Combo1.Clear
   List1.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
   xstr = Format(xstr, "0.000")
   ystr = Format(ystr, "0.000")
   Label3.Caption = "位置：x=" + xstr & ",y=" + ystr
   featcount = 0
   layercount = -1
   '设置误差
   wc = 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, wc, "")   '数据集是以距离找到的
      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 "xj": theitem = recs("name").ValueAsString
           Case "shj": theitem = recs("name").ValueAsString
           Case "jmd": theitem = recs("name").ValueAsString
           Case "continent": theitem = recs("name").ValueAsString
        End Select
        Combo1.AddItem theitem
        recs.MoveNext
        Wend
      End If
    Next alayer
    
    Visible = True
    
    If featcount = 0 Then      '判断几个对象被找到
       Label4.Caption = "can't found!"
    Else
       Label4.Caption = Str(featcount) + "个被找到"
    End If
    
    If featcount > 0 Then
     Combo1.ListIndex = 0
     Call ident_list
    End If
    Screen.MousePointer = 0
End Sub
Sub ident_list()   '点击后在listbox中显示属性
    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 = Combo1.ListIndex
    If IsNull(Combo1.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
    '写属性
    Label5.Caption = "图层名: " + aname
    List1.Clear
    For Each afield In currec.Fields
    Select Case afield.Type
       Case moString
          List1.AddItem afield.Name + "=" + afield.Value
       Case moPoint
          Label6.Caption = "对象形状： 点"
       Case moLine
          Label6.Caption = "对象形状： 线"
       Case moPolygon
          Label6.Caption = "对象形状： 多边形"
       Case Else
          List1.AddItem afield.Name + "=" + afield.ValueAsString
    End Select
    Next afield
End Sub
Private Sub Combo1_Click()
    ident_list
End Sub