form1.frm

有关ＶＢ在GIS空间分析方面的应用 深入详解代码大家在这方面多交流啊

VERSION 5.00
Object = "{C552EA90-6FBB-11D5-A9C1-00104BB6FC1C}#1.0#0"; "MapControl.ocx"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   6030
   ClientLeft      =   165
   ClientTop       =   855
   ClientWidth     =   8505
   LinkTopic       =   "Form1"
   ScaleHeight     =   6030
   ScaleWidth      =   8505
   StartUpPosition =   3  'Windows Default
   Begin esriMapControl.MapControl MapControl1 
      Height          =   5655
      Left            =   240
      OleObjectBlob   =   "Form1.frx":0000
      TabIndex        =   0
      Top             =   240
      Width           =   8055
   End
   Begin VB.Menu Buffer 
      Caption         =   "缓冲区分析"
      Begin VB.Menu Buffer_Generate 
         Caption         =   "生成缓冲区图层"
      End
      Begin VB.Menu Buffer_Analysis 
         Caption         =   "进行缓冲区分析"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public m_Buffer As Double
Public featureclass As IFeatureClass
Public pInputFeatureLayer As IFeatureLayer

Private Sub Buffer_Analysis_Click()
  Dim sPath As String
  sPath = "C:\temp"
  If Dir$("c:\temp\Buffer.shp") = "" Then
    MsgBox "没有生成缓冲区图层，请先生成缓冲区图层！"
    Exit Sub
  End If
  If Not Dir$("c:\temp\Clip_result.shp") = "" Then
    Kill "C:\temp\Clip_result.*"
  End If
  Dim pWorkspaceFactory As IWorkspaceFactory
  
 Set pWorkspaceFactory = New ShapefileWorkspaceFactory
  Dim pFeatureWorkspace As IFeatureWorkspace
  Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(sPath, 0)
  Dim pClipFeatureLayer As IFeatureLayer
  Set pClipFeatureLayer = New featurelayer
  Set pClipFeatureLayer.featureclass = pFeatureWorkspace.OpenFeatureClass("Buffer")
  pClipFeatureLayer.Name = pClipFeatureLayer.featureclass.AliasName
  
  Clip pInputFeatureLayer, pClipFeatureLayer
  
End Sub

Private Sub Buffer_Generate_Click()
   Dialog.Show
End Sub
Public Sub Clip(pInputLayer As ILayer, pClipLayer As ILayer)
  Dim pInputFeatLayer As IFeatureLayer
  Set pInputFeatLayer = pInputLayer
  Dim pInputTable As ITable
  Set pInputTable = pInputLayer
  Dim pInputFeatClass As IFeatureClass
  Set pInputFeatClass = pInputFeatLayer.featureclass
  Dim pClipTable As ITable
  Set pClipTable = pClipLayer
  If pInputTable Is Nothing Then
      MsgBox "Table QI failed"
      Exit Sub
  End If
 If pClipTable Is Nothing Then
      MsgBox "Table QI failed"
      Exit Sub
  End If
  Dim pFeatClassName As IFeatureClassName
  Set pFeatClassName = New FeatureClassName
  With pFeatClassName
      .FeatureType = esriFTSimple
      .ShapeFieldName = "Shape"
      .ShapeType = pInputFeatClass.ShapeType
  End With
  Dim pNewWSName As IWorkspaceName
  Set pNewWSName = New WorkspaceName
  pNewWSName.WorkspaceFactoryProgID = "esriDataSourcesFile.ShapefileWorkspaceFactory"
  pNewWSName.PathName = "C:\temp"
  Dim pDatasetName As IDatasetName
  Set pDatasetName = pFeatClassName
  pDatasetName.Name = "Clip_result"
  Set pDatasetName.WorkspaceName = pNewWSName
  ' Set the tolerance.  Passing 0.0 causes the default tolerance to be used.
  ' The default tolerance is 1/10,000 of the extent of the data frame's spatial domain
  Dim tol As Double
  tol = 0#
  ' Perform the clip
  Dim pBGP As IBasicGeoprocessor
  Set pBGP = New BasicGeoprocessor
  Dim pOutputFeatClass As IFeatureClass
  Set pOutputFeatClass = pBGP.Clip(pInputTable, False, pClipTable, False, _
    tol, pFeatClassName)
  ' Add the output layer (clipped features) to the map
   MapControl1.ClearLayers
  Dim pOutputFeatLayer As IFeatureLayer
  Set pOutputFeatLayer = New featurelayer
  Set pOutputFeatLayer.featureclass = pOutputFeatClass
  pOutputFeatLayer.Name = pOutputFeatClass.AliasName
  MapControl1.AddLayer pOutputFeatLayer, 0
  End Sub

Private Sub Form_Load()
   MapControl1.Extent = MapControl1.FullExtent
   Dim i As Integer
   Dim n As Integer
   n = 0
   For i = 0 To MapControl1.LayerCount - 1
      If MapControl1.Layer(i).Name = "channel" Or MapControl1.Layer(i).Name = "point" Then
         n = n + 1
      End If
      If MapControl1.Layer(i).Name = "point" Then
         Set pInputFeatureLayer = MapControl1.Layer(i)
      End If
   Next i
   If n <> 2 Then MsgBox "图层中必须包含“point”与“channle”图层，请重新载入"
   End Sub