module1.bas

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

Attribute VB_Name = "Module1"
Public featureclass As IFeatureClass
Public Sub CreateShapefile(sPath As String, sName As String, CreateShapefile As IFeatureClass) ' Dont include .shp extension
  Dim pFWS As IFeatureWorkspace
  Dim pWorkspaceFactory As IWorkspaceFactory
  Set pWorkspaceFactory = New ShapefileWorkspaceFactory
  Set pFWS = pWorkspaceFactory.OpenFromFile(sPath, 0)
 ' Set up a simple fields collection
  Dim pFields As IFields
  Dim pFieldsEdit As IFieldsEdit
  Set pFields = New Fields
  Set pFieldsEdit = pFields
  Dim pField As IField
  Dim pFieldEdit As IFieldEdit
' 定义shape field，需要定义该图层的几何类型和空间坐标系
  Set pField = New Field
  Set pFieldEdit = pField
  pFieldEdit.Name = "Shape"
  pFieldEdit.Type = esriFieldTypeGeometry
  Dim pSpa As ISpatialReference
  Dim pGeomDef As IGeometryDef
  Dim pGeomDefEdit As IGeometryDefEdit
  Set pGeomDef = New GeometryDef
  Set pGeomDefEdit = pGeomDef
  Set pSpa = New UnknownCoordinateSystem
  'Set pSpa = Form1.MapControl1.Map.SpatialReference
  With pGeomDefEdit
    .GeometryType = esriGeometryPolygon
    '.GeometryType = esriGeometryPolyline
 Set .SpatialReference = pSpa
  End With
  Set pFieldEdit.GeometryDef = pGeomDef
  pFieldsEdit.AddField pField
 '添加另一个 名为“Misc text” 的属性
  Set pField = New Field
  Set pFieldEdit = pField
With pFieldEdit
      .length = 30
      .Name = "MiscText"
      .Type = esriFieldTypeString
  End With
  pFieldsEdit.AddField pField
  ' Create the shapefile
  ' (some parameters apply to geodatabase options and can be defaulted as Nothing)
  Dim pFeatClass As IFeatureClass
  Set pFeatClass = pFWS.CreateFeatureClass(sName, pFields, Nothing, Nothing, esriFTSimple, "Shape", "")
  Set CreateShapefile = pFeatClass

End Sub

Public Sub CreateFeature(pFeatureClass As IFeatureClass, pGeom As IGeometry)
  Dim pWorkspaceEdit As IWorkspaceEdit
  Dim pFeatureLayer As IFeatureLayer
  Dim pfeature As IFeature
  Dim pDataset As IDataset
    If pGeom Is Nothing Then Exit Sub
    ' Create the feature
   Set pDataset = pFeatureClass
  If pDataset Is Nothing Then Exit Sub
  Set pWorkspaceEdit = pDataset.Workspace
  pWorkspaceEdit.StartEditOperation
  Set pfeature = pFeatureClass.CreateFeature
 Set pfeature.Shape = pGeom
  pfeature.Store
  pWorkspaceEdit.StopEditOperation
End Sub
Public 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