module1.bas

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

Attribute VB_Name = "Module1"
Option Explicit

Public m_pCurrentLayer As ILayer
Public m_pMap As IMap
Public m_pLayer As IFeatureLayer

' Uses the ratio of the size of the map in pixels to map units to do the conversion
Private Function ConvertPixelsToMapUnits(pActiveView As IActiveView, pixelUnits As Double) As Double
  Dim realWorldDisplayExtent As Double
  Dim pixelExtent As Integer
  Dim sizeOfOnePixel As Double

  pixelExtent = pActiveView.ScreenDisplay.DisplayTransformation.DeviceFrame.Right - pActiveView.ScreenDisplay.DisplayTransformation.DeviceFrame.Left
  realWorldDisplayExtent = pActiveView.ScreenDisplay.DisplayTransformation.VisibleBounds.Width
  sizeOfOnePixel = realWorldDisplayExtent / pixelExtent
  ConvertPixelsToMapUnits = pixelUnits * sizeOfOnePixel
End Function


Public Sub SelectMouseDown(x As Long, y As Long)
  Dim pFeatureLayer As IFeatureLayer
  Dim pFeatureClass As IFeatureClass
  Dim pSpatialFilter As ISpatialFilter
  Dim pFilter As IQueryFilter
  Dim pActiveView As IActiveView
  Dim pGeometry As IGeometry
  Dim pPoint As IPoint
  Dim str As String     ' 定义shaptype
  Dim n As Long
  
  On Error GoTo SelectMouseDown_err
  
  If m_pCurrentLayer Is Nothing Then Exit Sub
  If Not TypeOf m_pCurrentLayer Is IGeoFeatureLayer Then Exit Sub
  

  Set pFeatureLayer = m_pCurrentLayer
  Set pFeatureClass = pFeatureLayer.FeatureClass
  If pFeatureClass Is Nothing Then Exit Sub
  
  Set pActiveView = m_pMap
  Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  Set pGeometry = pPoint
  

  Dim length As Double
  length = ConvertPixelsToMapUnits(m_pMap, 4)
  Dim pTopo As ITopologicalOperator
  Set pTopo = pGeometry
  Dim pBuffer As IGeometry
  Set pBuffer = pTopo.Buffer(length)
  Set pGeometry = pBuffer.envelope
  

  Set pSpatialFilter = New SpatialFilter
  Set pSpatialFilter.Geometry = pGeometry
  Select Case pFeatureClass.ShapeType
    Case esriGeometryPoint
      pSpatialFilter.SpatialRel = esriSpatialRelContains
      str = "Point"
    Case esriGeometryPolyline
      pSpatialFilter.SpatialRel = esriSpatialRelCrosses
      str = "Polyline"
    Case esriGeometryPolygon
      pSpatialFilter.SpatialRel = esriSpatialRelIntersects
      str = "Polygon"
  End Select
  pSpatialFilter.GeometryField = pFeatureClass.ShapeFieldName
  Set pFilter = pSpatialFilter
 

  Dim pCursor As IFeatureCursor
  Set pCursor = pFeatureLayer.Search(pFilter, False)


  Dim pfeature As ifeature
  Set pfeature = pCursor.NextFeature
  While Not pfeature Is Nothing
    m_pMap.SelectFeature m_pCurrentLayer, pfeature
   
   '向属性表中添加Filds
  ' *********************************************************************
  Form2.Grid.Cols = pfeature.Fields.FieldCount + 1
  For n = 1 To Form2.Grid.Cols - 1
    Form2.Grid.TextMatrix(0, n) = m_pLayer.FeatureClass.Fields.Field(n - 1).AliasName
     If n <> 2 Then
         Form2.Grid.TextMatrix(1, n) = pfeature.Value(CLng(n - 1))
     Else
         Form2.Grid.TextMatrix(1, n) = str
     End If
  Next n
  ' *********************************************************************
    
    Set pfeature = pCursor.NextFeature
    
  Wend
  pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
  
  Exit Sub
SelectMouseDown_err:
  MsgBox Err.Description
End Sub

Public Sub SelectMouseTrackRectangle(envelope As IEnvelope)
  Dim pFeatureLayer As IFeatureLayer
  Dim pFeatureClass As IFeatureClass
  Dim pSpatialFilter As ISpatialFilter
  Dim pFilter As IQueryFilter
  Dim pActiveView As IActiveView
  Dim pGeometry As IGeometry
  Dim pPoint As IPoint
  Dim i As Long
  Dim str As String
  i = 0
  Dim n As Long
  
  On Error GoTo SelectMouseDown_err
  
  If m_pCurrentLayer Is Nothing Then Exit Sub
  If Not TypeOf m_pCurrentLayer Is IGeoFeatureLayer Then Exit Sub
  

  Set pFeatureLayer = m_pCurrentLayer
  Set pFeatureClass = pFeatureLayer.FeatureClass
  If pFeatureClass Is Nothing Then Exit Sub
  
  
  
  Set pGeometry = envelope
  Set pActiveView = m_pMap

  Set pSpatialFilter = New SpatialFilter
  Set pSpatialFilter.Geometry = pGeometry
  Select Case pFeatureClass.ShapeType
    Case esriGeometryPoint
      pSpatialFilter.SpatialRel = esriSpatialRelContains
      str = "Point"
    Case esriGeometryPolyline
      pSpatialFilter.SpatialRel = esriSpatialRelCrosses Or esriSpatialRelContains
      str = "Polyline"
    Case esriGeometryPolygon
      pSpatialFilter.SpatialRel = esriSpatialRelIntersects
      str = "Polygon"
  End Select
  pSpatialFilter.GeometryField = pFeatureClass.ShapeFieldName
  Set pFilter = pSpatialFilter
 
 
  Dim pCursor As IFeatureCursor
  Set pCursor = pFeatureLayer.Search(pFilter, False)
 
  Dim pfeature As ifeature
  Set pfeature = pCursor.NextFeature
  While Not pfeature Is Nothing
    
    m_pMap.SelectFeature m_pCurrentLayer, pfeature
    pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
    i = i + 1             '控制属性表的列数
    Set pfeature = pCursor.NextFeature
    
  Wend
 '向属性表中添加Filds
  ' *********************************************************************
  Form2.Grid.Rows = i + 1
  Form2.Grid.Cols = m_pLayer.FeatureClass.Fields.FieldCount + 1
  For n = 1 To Form2.Grid.Cols - 1
  Form2.Grid.TextMatrix(0, n) = m_pLayer.FeatureClass.Fields.Field(n - 1).AliasName
  Next n
  
   
  ' *********************************************************************
  Set pCursor = pFeatureLayer.Search(pFilter, False)
  Set pfeature = pCursor.NextFeature
  i = 0
  While Not pfeature Is Nothing
         
    '向属性表中添加value
    '*********************************************************************
    For n = 1 To Form2.Grid.Cols - 1
      If n <> 2 Then
         Form2.Grid.TextMatrix(i + 1, n) = pfeature.Value(CLng(n - 1))
      Else
         Form2.Grid.TextMatrix(i + 1, n) = str
      End If
    Next n
    '*********************************************************************
    
    i = i + 1
    Set pfeature = pCursor.NextFeature
    
  Wend
  Exit Sub
SelectMouseDown_err:
  MsgBox Err.Description
End Sub

Public Sub SelectMouseTrackLine(pGeoline As IGeometry)
  Dim pFeatureLayer As IFeatureLayer
  Dim pFeatureClass As IFeatureClass
  Dim pSpatialFilter As ISpatialFilter
  Dim pFilter As IQueryFilter
  Dim pActiveView As IActiveView
  Dim pGeometry As IGeometry
  Dim pPoint As IPoint
  Dim str As String
  Dim i As Long
  i = 0
  Dim n As Long
  
  On Error GoTo SelectMouseDown_err
  
  If m_pCurrentLayer Is Nothing Then Exit Sub
  If Not TypeOf m_pCurrentLayer Is IGeoFeatureLayer Then Exit Sub
  

  Set pFeatureLayer = m_pCurrentLayer
  Set pFeatureClass = pFeatureLayer.FeatureClass
  If pFeatureClass Is Nothing Then Exit Sub
  
 
  Set pGeometry = pGeoline
  Set pActiveView = m_pMap

  Set pSpatialFilter = New SpatialFilter
  Set pSpatialFilter.Geometry = pGeometry
  Select Case pFeatureClass.ShapeType
    Case esriGeometryPoint
      pSpatialFilter.SpatialRel = esriSpatialRelContains
      str = "Point"
    Case esriGeometryPolyline
      pSpatialFilter.SpatialRel = esriSpatialRelIntersects
      str = "Polyline"
    Case esriGeometryPolygon
      pSpatialFilter.SpatialRel = esriSpatialRelIntersects
      str = "Polygon"
  End Select
  pSpatialFilter.GeometryField = pFeatureClass.ShapeFieldName
  Set pFilter = pSpatialFilter
 
 
  Dim pCursor As IFeatureCursor
  Set pCursor = pFeatureLayer.Search(pFilter, False)

  Dim pfeature As ifeature
  Set pfeature = pCursor.NextFeature
  While Not pfeature Is Nothing
    
    m_pMap.SelectFeature m_pCurrentLayer, pfeature
    pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
     i = i + 1
    Set pfeature = pCursor.NextFeature
    
  Wend
  '向属性表中添加Filds
  ' *********************************************************************
  Form2.Grid.Rows = i + 1
  Form2.Grid.Cols = m_pLayer.FeatureClass.Fields.FieldCount + 1
  For n = 1 To Form2.Grid.Cols - 1
  Form2.Grid.TextMatrix(0, n) = m_pLayer.FeatureClass.Fields.Field(n - 1).AliasName
  Next n
  
   
  ' *********************************************************************
  Set pCursor = pFeatureLayer.Search(pFilter, False)
  Set pfeature = pCursor.NextFeature
  i = 0
  While Not pfeature Is Nothing
         
    '向属性表中添加value
    '*********************************************************************
    For n = 1 To Form2.Grid.Cols - 1
      If n <> 2 Then
         Form2.Grid.TextMatrix(i + 1, n) = pfeature.Value(CLng(n - 1))
      Else
         Form2.Grid.TextMatrix(i + 1, n) = str
      End If
    Next n
    '*********************************************************************
    
    i = i + 1
    Set pfeature = pCursor.NextFeature
    
  Wend
  
  Exit Sub
SelectMouseDown_err:
  MsgBox Err.Description
End Sub
Public Sub SelectMouseTrackPoly(pGeoline As IGeometry)
  Dim pFeatureLayer As IFeatureLayer
  Dim pFeatureClass As IFeatureClass
  Dim pSpatialFilter As ISpatialFilter
  Dim pFilter As IQueryFilter
  Dim pActiveView As IActiveView
  Dim pGeometry As IGeometry
  Dim pPoint As IPoint
  Dim str As String
  Dim i As Long
  i = 0
  Dim n As Long
  
  On Error GoTo SelectMouseDown_err
  
  If m_pCurrentLayer Is Nothing Then Exit Sub
  If Not TypeOf m_pCurrentLayer Is IGeoFeatureLayer Then Exit Sub
  

  Set pFeatureLayer = m_pCurrentLayer
  Set pFeatureClass = pFeatureLayer.FeatureClass
  If pFeatureClass Is Nothing Then Exit Sub
  
 
  Set pGeometry = pGeoline
  Set pActiveView = m_pMap

  Set pSpatialFilter = New SpatialFilter
  Set pSpatialFilter.Geometry = pGeometry
  Select Case pFeatureClass.ShapeType
    Case esriGeometryPoint
      pSpatialFilter.SpatialRel = esriSpatialRelContains
      str = "Point"
    Case esriGeometryPolyline
      pSpatialFilter.SpatialRel = esriSpatialRelIntersects Or esriSpatialRelContains
      str = "Polyline"
    Case esriGeometryPolygon
      pSpatialFilter.SpatialRel = esriSpatialRelIntersects
      str = "Polygon"
  End Select
  pSpatialFilter.GeometryField = pFeatureClass.ShapeFieldName
  Set pFilter = pSpatialFilter
 
 
  Dim pCursor As IFeatureCursor
  Set pCursor = pFeatureLayer.Search(pFilter, False)

  Dim pfeature As ifeature
  Set pfeature = pCursor.NextFeature
  While Not pfeature Is Nothing
    
    m_pMap.SelectFeature m_pCurrentLayer, pfeature
    pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
     i = i + 1
    Set pfeature = pCursor.NextFeature
    
  Wend
  '向属性表中添加Filds
  ' *********************************************************************
  Form2.Grid.Rows = i + 1
  Form2.Grid.Cols = m_pLayer.FeatureClass.Fields.FieldCount + 1
  For n = 1 To Form2.Grid.Cols - 1
  Form2.Grid.TextMatrix(0, n) = m_pLayer.FeatureClass.Fields.Field(n - 1).AliasName
  Next n
  
   
  ' *********************************************************************
  Set pCursor = pFeatureLayer.Search(pFilter, False)
  Set pfeature = pCursor.NextFeature
  i = 0
  While Not pfeature Is Nothing
          
    '向属性表中添加value
    '*********************************************************************
    For n = 1 To Form2.Grid.Cols - 1
      If n <> 2 Then
         Form2.Grid.TextMatrix(i + 1, n) = pfeature.Value(CLng(n - 1))
      Else
         Form2.Grid.TextMatrix(i + 1, n) = str
      End If
    Next n
    '*********************************************************************
    
    i = i + 1
    Set pfeature = pCursor.NextFeature
    
  Wend
  
  Exit Sub
SelectMouseDown_err:
  MsgBox Err.Description
End Sub