叠置分析.frm

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

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form 叠置分析 
   Caption         =   "Form1"
   ClientHeight    =   5265
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   8040
   LinkTopic       =   "Form1"
   ScaleHeight     =   5265
   ScaleWidth      =   8040
   StartUpPosition =   3  'Windows Default
   WindowState     =   2  'Maximized
   Begin VB.Frame Frame1 
      Caption         =   "多变形与多边形"
      Height          =   4455
      Left            =   5520
      TabIndex        =   2
      Top             =   600
      Width           =   2200
      Begin VB.CommandButton cmdagain 
         Caption         =   "重新选择"
         Height          =   495
         Left            =   480
         TabIndex        =   9
         Top             =   3720
         Width           =   1215
      End
      Begin VB.CommandButton cmdstart 
         Caption         =   "叠置分析"
         Height          =   495
         Left            =   480
         TabIndex        =   5
         Top             =   1680
         Width           =   1215
      End
      Begin VB.CommandButton Cmdpolygon 
         Caption         =   "画多边形"
         Height          =   495
         Left            =   480
         TabIndex        =   4
         Top             =   960
         Width           =   1215
      End
      Begin VB.CommandButton cmdselect 
         Caption         =   "选择块地"
         Height          =   495
         Left            =   480
         TabIndex        =   3
         Top             =   360
         Width           =   1215
      End
      Begin VB.Label Labunit 
         Height          =   375
         Left            =   600
         TabIndex        =   8
         Top             =   3240
         Width           =   1095
      End
      Begin VB.Label labarea 
         Height          =   255
         Left            =   480
         TabIndex        =   7
         Top             =   2760
         Width           =   1215
      End
      Begin VB.Label Label1 
         Caption         =   "重叠区面积是："
         Height          =   255
         Left            =   480
         TabIndex        =   6
         Top             =   2400
         Width           =   1455
      End
   End
   Begin MapObjects2.Map Map1 
      Height          =   4335
      Left            =   100
      TabIndex        =   1
      Top             =   700
      Width           =   4935
      _Version        =   131072
      _ExtentX        =   8705
      _ExtentY        =   7646
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "叠置分析.frx":0000
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   720
      Top             =   4560
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSComctlLib.Toolbar Toolbar1 
      Align           =   1  'Align Top
      Height          =   615
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   8040
      _ExtentX        =   14182
      _ExtentY        =   1085
      ButtonWidth     =   1455
      ButtonHeight    =   926
      Appearance      =   1
      ImageList       =   "ImageList1"
      _Version        =   393216
      BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628} 
         NumButtons      =   6
         BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "放大"
            Key             =   "zoomin"
            ImageIndex      =   1
         EndProperty
         BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "缩小"
            Key             =   "zoomout"
            ImageIndex      =   3
         EndProperty
         BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "漫游"
            Key             =   "pan"
            ImageIndex      =   4
         EndProperty
         BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "全图"
            Key             =   "globe"
            ImageIndex      =   5
         EndProperty
         BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "画多边形"
            Key             =   "poly"
            ImageIndex      =   6
         EndProperty
         BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "恢复"
            Key             =   "arrow"
            ImageIndex      =   2
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   120
      Top             =   4440
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   6
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "叠置分析.frx":001A
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "叠置分析.frx":012C
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "叠置分析.frx":023E
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "叠置分析.frx":0350
            Key             =   ""
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "叠置分析.frx":0462
            Key             =   ""
         EndProperty
         BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "叠置分析.frx":0574
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Menu mnuopenshp 
      Caption         =   "打开shp文件"
   End
   Begin VB.Menu mnuopencov 
      Caption         =   "打开cov文件"
   End
   Begin VB.Menu mnuopencad 
      Caption         =   "打开cad文件"
   End
End
Attribute VB_Name = "叠置分析"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim rect As MapObjects2.polygon
Dim recselection As MapObjects2.Recordset
Dim intersectshape As MapObjects2.polygon
Dim resultshape As MapObjects2.polygon
Dim i As Integer
Dim j As Integer
Dim pot As MapObjects2.Point

Private Sub cmdagain_Click()
Set recselection = Nothing
Set intersectshape = Nothing
Set resultshape = Nothing
Set rect = Nothing
labarea.Caption = ""
Labunit.Caption = ""
Map1.Refresh
End Sub

Private Sub Cmdpolygon_Click()
Map1.MousePointer = moPencil
End Sub

Private Sub cmdselect_Click()
Map1.MousePointer = moHotLink
i = 1
End Sub

Private Sub cmdstart_Click()
 
  If Not recselection Is Nothing Then
  If Not rect Is Nothing Then
  Set intersectshape = recselection.Fields("shape").Value
  Set resultshape = rect.Intersect(intersectshape)
  Map1.FlashShape resultshape, 3
  labarea.Caption = resultshape.Area
  Labunit.Caption = "万平方公里"
  Else: MsgBox "请画多边形请画多边形"
  End If
  Else: MsgBox "请画多边形"
  End If
  
  Map1.Refresh
End Sub



Private Sub Form_Resize()
Map1.Move 100, 700, 叠置分析.ScaleWidth - frame1.Width - 400, 叠置分析.ScaleHeight - 800
frame1.Move 300 + Map1.Width, 700
End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
Dim sym1 As New MapObjects2.Symbol
If Not rect Is Nothing Then
  sym1.Color = moYellow
  Map1.DrawShape rect, sym1
End If

If Not recselection Is Nothing Then
 sym1.Color = moOrange
 Map1.DrawShape recselection, sym1
End If

If Not resultshape Is Nothing Then
 sym1.Color = moRed
 Map1.DrawShape resultshape, sym1
End If
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Set pot = Map1.ToMapPoint(X, Y)
Select Case Map1.MousePointer
        Case moZoomIn
        Set Map1.Extent = Map1.TrackRectangle
        
        
        Case moZoomOut
        Dim r As MapObjects2.Rectangle
        Set r = Map1.Extent
        r.ScaleRectangle 1.5
        Map1.Extent = r
                  
        Case moPan
        Map1.Pan
        
        Case moArrow
        Map1.MousePointer = moArrow
        
        Case moPencil
        Set rect = Map1.TrackPolygon
        Map1.Refresh
        
    End Select
    
    If i = 1 Then
        Set recselection = Map1.Layers(0).SearchShape(pot, moPointInPolygon, "")
        Map1.Refresh
       i = 0
    End If
    Map1.Refresh
End Sub

Private Sub mnuopencad_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 = "Drawing (*.dwg)|*.dwg*|DXF (*.dxf)|*.dxf"
  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
  'This loop goes backwards through the string, searching for the
  'last back slash. This marks the base path from the returned string.
  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))
   workspace = basepath
  'Also, feature attribute tables are specified by the coverage name followed
  'by the feature attribute table, minus its .adf extension...
  dCon.Database = "[CAD]" & workspace                    'Set Database property of DataConnection
  If dCon.Connect Then
    Set gSet = dCon.FindGeoDataset(featAttTable) 'Find shapefile as GeoDataset in DataConnection
    If gSet Is Nothing Then
      MsgBox "Error opening Auto CAD files " & featAttTable
      Exit Sub
    Else
      Dim newLayer As New MapLayer
      newLayer.GeoDataset = gSet            'Set GeoDataset property of new MapLayer
      newLayer.Name = featAttTable          'Set Name property of new MapLayer
      
    '  newLayer.Symbol.Color = moGreen
      
      Map1.Layers.Add newLayer
      Map1.Refresh
      'Add MapLayer to Layers collection
      
    End If
  Else
    'MsgBox ConnectErrorMsg(dCon.ConnectError), vbCritical, "Connection error"
  End If
  
End Sub

Private Sub mnuopencov_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 = "arc/info coverage(*.adf)|*.adf"
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
workspace = "[arc]" & Left$(basepath, textPos - 1)
Dim coverage As String
Dim lenbasepath As Long
Dim ext As String
ext = LCase(Right$(filename, 3))
lenbasepath = Len(basepath)
coverage = Right$(basepath, lenbasepath - textPos)
If ext = "adf" Then
   featAttTable = coverage & "." & Left$(filename, Len(filename) - 4)
Else
   featattbable = coverage & "." & ext & Left$(filename, Len(filename) - 4)
End If
featAttTable = LCase(featAttTable)
workspace = LCase(workspace)
dCon.Database = workspace
If dCon.Connect Then
  Set gSet = dCon.FindGeoDataset(featAttTable)
  If gSet Is Nothing Then
     MsgBox "error opening coverage featrue attribute table" & featAttTable
     Exit Sub
  Else
     Dim newLayer As New MapLayer
     newLayer.GeoDataset = gSet
     newLayer.Name = featAttTable
     
  End If
   
End If
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 = moGreen
    Map1.Layers.Add newLayer
    Map1.Refresh
  End If
End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
            Case "zoomin"
                Map1.MousePointer = moZoomIn
            Case "zoomout"
               Map1.MousePointer = moZoomOut

            Case "pan"
               Map1.MousePointer = moPan
               
            Case "globe"
                Map1.Extent = Map1.FullExtent
              
            Case "arrow"
                Map1.MousePointer = moArrow
            Case "poly"
                Map1.MousePointer = moPencil
                
             
 End Select
End Sub
Sub drawresult()

End Sub