空间查询.frm

本程序利用vb实现了地理信息系统中空间分析的各种方法

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form 空间查询 
   AutoRedraw      =   -1  'True
   Caption         =   "Form1"
   ClientHeight    =   6630
   ClientLeft      =   1995
   ClientTop       =   750
   ClientWidth     =   9210
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   6630
   ScaleWidth      =   9210
   WindowState     =   2  'Maximized
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   360
      Top             =   6480
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Frame frame1 
      Caption         =   "查询结果"
      Height          =   3975
      Left            =   6000
      TabIndex        =   2
      Top             =   2400
      Width           =   2895
      Begin VB.ComboBox Comfeatures 
         Height          =   315
         Left            =   120
         TabIndex        =   6
         Top             =   240
         Width           =   2655
      End
      Begin VB.ListBox lstFeatList 
         Height          =   4935
         Left            =   120
         TabIndex        =   3
         Top             =   960
         Width           =   2655
      End
      Begin VB.Label lblShapeType 
         Height          =   255
         Left            =   240
         TabIndex        =   5
         Top             =   2160
         Width           =   2295
      End
      Begin VB.Label lblTheme 
         Height          =   255
         Left            =   240
         TabIndex        =   4
         Top             =   1800
         Width           =   2295
      End
   End
   Begin VB.ComboBox Comlayers 
      Height          =   315
      Left            =   6120
      TabIndex        =   1
      Top             =   1800
      Width           =   2775
   End
   Begin MapObjects2.Map Map1 
      Height          =   6375
      Left            =   120
      TabIndex        =   0
      Top             =   0
      Width           =   5775
      _Version        =   131072
      _ExtentX        =   10186
      _ExtentY        =   11245
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "空间查询.frx":0000
   End
   Begin VB.Frame Frame2 
      Caption         =   "查询方法"
      Height          =   1695
      Left            =   6120
      TabIndex        =   7
      Top             =   0
      Width           =   2775
      Begin VB.OptionButton optpolygon 
         Caption         =   "多边形包含查询"
         Height          =   255
         Left            =   120
         TabIndex        =   10
         Top             =   1320
         Width           =   1695
      End
      Begin VB.OptionButton optline 
         Caption         =   "穿越查询"
         Height          =   255
         Left            =   120
         TabIndex        =   9
         Top             =   840
         Width           =   1575
      End
      Begin VB.OptionButton optpoint 
         Caption         =   "点查询"
         Height          =   255
         Left            =   120
         TabIndex        =   8
         Top             =   360
         Width           =   1335
      End
   End
   Begin VB.Menu mnuopenshp 
      Caption         =   "打开shp文件"
   End
End
Attribute VB_Name = "空间查询"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim i As Integer
Dim n As Integer
Dim j As Integer
Dim rect As MapObjects2.Recordset
Dim rect1 As MapObjects2.Recordset
Dim pot As MapObjects2.Point
Dim afield As Object
Dim line1 As MapObjects2.Line
Dim polygon As MapObjects2.polygon
Dim lyr As MapLayer
Dim sym As New MapObjects2.Symbol

Private Sub Comfeatures_click()

lstFeatList.Clear
rect.MoveFirst
Do While Not rect.EOF
If rect.Fields("name").ValueAsString = Comfeatures.Text Then
Map1.FlashShape rect.Fields("shape").Value, 2
For Each afield In rect.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
End If
rect.MoveNext
Loop

End Sub

Private Sub Comlayers_Click()

For n = 0 To Map1.Layers.Count - 1
    Set lyr = Map1.Layers(n)
    If lyr.Name = Comlayers.Text Then
       Map1.Layers.MoveTo n, 0
    End If
Next
Map1.Refresh
End Sub

Private Sub Form_Load()
Comlayers.Text = "请选择当前图层"
End Sub


Private Sub Form_Resize()
Map1.Move 100, 100, 空间查询.ScaleWidth - 500 - frame1.Width, 空间查询.ScaleHeight - 300
Frame2.Move Map1.Width + 300, 100, 2900
frame1.Move Map1.Width + 300, 2400, 2900, 空间查询.ScaleHeight - 2600
Comlayers.Move Map1.Width + 300, 2000
lstFeatList.Move 100, 700, frame1.Width - 200, frame1.Height - 750
End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)

If Not line1 Is Nothing Then
Map1.DrawShape line1, sym
End If

If Not polygon Is Nothing Then
Map1.DrawShape polygon, sym
End If

If Not rect Is Nothing Then
rect.MoveFirst
   Do While Not rect.EOF
   Map1.DrawShape rect.Fields("shape").Value, sym
   rect.MoveNext
   Loop
End If
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   lstFeatList.Clear
   Comfeatures.Clear

   Select Case i
   Case 1
   Set line1 = Nothing
   Set polygon = Nothing
   Set pot = Map1.ToMapPoint(X, Y)
   Set rect = Map1.Layers(0).SearchByDistance(pot, 0.5, "")
   
   If Not rect Is Nothing Then
   rect.MoveFirst
   Do While Not rect.EOF
   Map1.FlashShape rect.Fields("shape").Value, 1
   rect.MoveNext
   Loop
   Else: MsgBox "没有找到符合要求的地物"
   End If
   
   Call identify
   
   Case 2
   Set polygon = Nothing
   
   Set line1 = Map1.TrackLine
   Set rect = Map1.Layers(0).SearchShape(line1, moEdgeTouchOrAreaIntersect, "")
   sym.Color = moRed
   
   If Not rect Is Nothing Then
   rect.MoveFirst
   Do While Not rect.EOF
   Map1.FlashShape rect.Fields("shape").Value, 1
   rect.MoveNext
   Loop
   Else: MsgBox "没有找到符合要求的地物"
   End If
   
   Call identify
   
   Case 3
   Set line1 = Nothing
   Set polygon = Map1.TrackPolygon
   Set rect = Map1.Layers(0).SearchShape(polygon, moAreaIntersect, "")
   sym.Color = moOrange
   
   If Not rect Is Nothing Then
   rect.MoveFirst
   Do While Not rect.EOF
   Map1.FlashShape rect.Fields("shape").Value, 1
   rect.MoveNext
   Loop
   Else: MsgBox "没有找到符合要求的地物"
   End If
   
   Call identify
   
   End Select
   
   
   Map1.Refresh
     
End Sub


Private Sub mnuopenshp_Click()
Dim basepath As String
Dim filename As String
Dim dCon As New DataConnection
Dim gSet As GeoDataset
Dim str As String
Dim textPos As Long, periodPos As Long
Dim Test As Boolean
Dim tempChar As String
Dim fullFile As String, workspace As String, featAttTable As String
CommonDialog1.Filter = "esri shapefile(*.shp)|*.shp"
CommonDialog1.ShowOpen
basepath = CurDir
filename = CommonDialog1.FileTitle
   If filename = "" Then
      MsgBox ("you haven't select layer!")
      Exit Sub
   End If
fullFile = Trim$(CommonDialog1.filename)
textPos = Len(basepath)
Test = False
Do While Test = False
    textPos = textPos - 1
    tempChar = Mid$(basepath, textPos, 1)
    If tempChar = "." Then
       periodPos = textPos
    ElseIf tempChar = "\" Or textPos = 0 Then
    Test = True
    End If
 Loop
featAttTable = Left$(filename, Len(filename) - 4)
workspace = basepath
dCon.Database = workspace
If dCon.Connect Then
  Set gSet = dCon.FindGeoDataset(featAttTable)
  If gSet Is Nothing Then
     MsgBox "error spening esri shapefile" & featAttTable
     Exit Sub
  Else
    Dim newLayer As New MapLayer
    newLayer.GeoDataset = gSet
    newLayer.Name = featAttTable
    'newLayer.Symbol.Color = RGB(100, 250, 100)
    Map1.Layers.Add newLayer
    Map1.Refresh
    Comlayers.AddItem newLayer.Name
    
  End If
End If
End Sub

Private Sub optline_Click()
i = 2
Map1.MousePointer = moCross
End Sub

Private Sub optpoint_Click()
i = 1
Map1.MousePointer = moCross
End Sub
Private Sub identify()

If Not rect Is Nothing Then

 rect.MoveFirst
 
 Do While Not rect.EOF
 Comfeatures.AddItem rect.Fields("name").ValueAsString
 rect.MoveNext
 Loop

Else
   MsgBox "no recordset!"
End If

End Sub

Private Sub optpolygon_Click()
i = 3
End Sub