属性.frm

vb+mo二次开发实现校园内的属性查询功能

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmattribute 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "属性"
   ClientHeight    =   7035
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   2460
   LinkTopic       =   "Form3"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   7035
   ScaleWidth      =   2460
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox Picture1 
      Height          =   1575
      Left            =   120
      ScaleHeight     =   1515
      ScaleWidth      =   1875
      TabIndex        =   8
      Top             =   2280
      Width           =   1935
   End
   Begin VB.ComboBox Combo1 
      Height          =   300
      Left            =   120
      TabIndex        =   7
      Text            =   "Combo1"
      Top             =   1800
      Width           =   1935
   End
   Begin VB.ListBox List1 
      Height          =   2220
      Left            =   120
      TabIndex        =   3
      Top             =   4560
      Width           =   2175
   End
   Begin MSComctlLib.ListView ListView1 
      Height          =   135
      Left            =   1800
      TabIndex        =   2
      Top             =   2160
      Width           =   30
      _ExtentX        =   53
      _ExtentY        =   238
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin VB.Image Image1 
      Height          =   6225
      Left            =   -10800
      Picture         =   "属性.frx":0000
      Top             =   -4080
      Width           =   9000
   End
   Begin VB.Label Label7 
      Caption         =   "选定对象："
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   1440
      Width           =   1215
   End
   Begin VB.Label Label6 
      Height          =   375
      Left            =   120
      TabIndex        =   5
      Top             =   960
      Width           =   1695
   End
   Begin VB.Label Label3 
      Caption         =   "图层名"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   600
      Width           =   1695
   End
   Begin VB.Label Label2 
      Caption         =   "属性"
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   4080
      Width           =   1215
   End
   Begin VB.Label Label1 
      Caption         =   "位置："
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   1575
   End
End
Attribute VB_Name = "frmattribute"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Const SEARCHTOLPIXELS = 3
Dim Loc As New Point
Dim Recs2() As mapobjects2.Recordset
Dim layerName() As String
Dim layerNum() As Long
Const HWND_TOPMOST = -1
Const SWP_NOSE = &H1
Const SWP_NOMOVE = &H2
Private Declare Sub SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)


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
  
  layer_c = frmmain.Map1.layers.Count
  ReDim layerName(layer_c)
  ReDim Recs2(layer_c)
  
  Screen.MousePointer = 11
 
  Combo1.Clear
  List1.Clear
  
  Set Loc = frmmain.Map1.ToMapPoint(x, y)
  Dim xStr As String, yStr As String
 
  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
  Label1.Caption = "Location:  (" & xStr & "," + yStr + ")"
  featCount = 0
  layerCount = -1
 
  theTol = frmmain.Map1.ToMapDistance(SEARCHTOLPIXELS * Screen.TwipsPerPixelX)
  
 
  For Each aLayer In frmmain.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
        theItem = recs("NAME").ValueAsString
        If theItem = "" Then
          Combo1.AddItem recs("NAME").ValueAsString
        Else
          Combo1.AddItem theItem
        End If
'        If recs("pname") = vbNullString Then
'            Picture1.Picture = LoadPicture(App.Path & "\data\picture\none.gif")
'        Else
'        Picture1.Picture = LoadPicture(App.Path & "\data\picture\" & recs("pname"))
'        End If
        recs.MoveNext
      Wend
    End If
  Next aLayer
  
  
  Visible = True
  
  
 
  If featCount > 0 Then
    Combo1.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
  If Combo1.List(Combo1.ListIndex) = "" 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

  frmmain.Map1.FlashShape curRec("shape").Value, 3

  Label3.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 Command1_Click()
window1.Show

End Sub

Private Sub list1_Click()
  Identify_list
End Sub

Private Sub Form_Load()

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