[讨论]关于要素类的复制问题(提供部分源码)

如果我不想创建一个新的featureclass,然后把要复制的要素类的所有属性拷贝到新的featureclass中,也不想用IFeatureDataConverter.ConvertFeatureClass (该方法的源码如下),我能用什么方法(比如icopyhelper接口和idataset.copy)来实现一个要素类的复制呢?(大多数的idataset.cancopy的值是false,即不能直接复制)

源码如下:

Public Sub FCLoader(pInPropertySet As IPropertySet, _
                        sInName As String, _
                        pOutPropertySet As IPropertySet, _
                        sOutName As String)
    
    ' Setup output workspace.
    Dim pOutWorkspaceName As IWorkspaceName
    Set pOutWorkspaceName = New WorkspaceName
    
    pOutWorkspaceName.ConnectionProperties = pOutPropertySet
    pOutWorkspaceName.WorkspaceFactoryProgID = "esriDataSourcesGDB.SDEWorkspaceFactory.1"
    
    ' Set up for open.
    Dim pInWorkspaceName As IWorkspaceName
    Set pInWorkspaceName = New WorkspaceName
    pInWorkspaceName.ConnectionProperties = pInPropertySet
    pInWorkspaceName.WorkspaceFactoryProgID = "esriDataSourcesFile.ShapefileWorkspaceFactory.1"
    ' Set in dataset and table names.
    Dim pInFCName As IFeatureClassName
    Set pInFCName = New FeatureClassName
    Dim pInDatasetName As IDatasetName
    Set pInDatasetName = pInFCName
    pInDatasetName.Name = sInName
    Set pInDatasetName.WorkspaceName = pInWorkspaceName
  
    ' Set out dataset and table names.
    Dim pOutDatasetName As IDatasetName
    Dim pOutFCName As IFeatureClassName
    Set pOutFCName = New FeatureClassName
    Set pOutDatasetName = pOutFCName
    Set pOutDatasetName.WorkspaceName = pOutWorkspaceName
    pOutDatasetName.Name = sOutName
   ' Open input Featureclass to get field definitions.
    Dim pName As IName
    Dim pInFC As IFeatureClass
    Set pName = pInFCName
    Set pInFC = pName.Open
    
    ' Validate the field names.
    Dim pOutFCFields As IFields
    Dim pInFCFields As IFields
    Dim pFieldCheck As IFieldChecker
    Dim i As Long
    
    Set pInFCFields = pInFC.Fields
    Set pFieldCheck = New FieldChecker
    pFieldCheck.Validate pInFCFields, Nothing, pOutFCFields
    
    ' +++ Loop through the output fields to find the geometry field
    Dim pGeoField As IField
    For i = 0 To pOutFCFields.FieldCount
        If pOutFCFields.Field(i).Type = esriFieldTypeGeometry Then
          Set pGeoField = pOutFCFields.Field(i)
          Exit For
        End If
    Next i
    ' +++ Get the geometry field's geometry defenition
    Dim pOutFCGeoDef As IGeometryDef
    Set pOutFCGeoDef = pGeoField.GeometryDef
    
    ' +++ Give the geometry definition a spatial index grid count and grid size
    Dim pOutFCGeoDefEdit As IGeometryDefEdit
    Set pOutFCGeoDefEdit = pOutFCGeoDef
    pOutFCGeoDefEdit.GridCount = 1
    pOutFCGeoDefEdit.GridSize(0) = DefaultIndexGrid(pInFC)
    Set pOutFCGeoDefEdit.SpatialReference = pGeoField.GeometryDef.SpatialReference
    
    Dim pQueryFilter As IQueryFilter
    Set pQueryFilter = New QueryFilter
    pQueryFilter.SubFields = "Shape,STATE_NAME"
    
    ' Load the table.
    Dim pFCToFC As IFeatureDataConverter
    Set pFCToFC = New FeatureDataConverter
    
    Dim pEnumErrors As IEnumInvalidObject
    Set pEnumErrors = pFCToFC.ConvertFeatureClass(pInFCName, pQueryFilter, Nothing, pOutFCName, pOutFCGeoDef, pOutFCFields, "", 1000, 0)
    
    ' If some of the records do not load, report to report window.
      
    Dim pErrInfo As IInvalidObjectInfo
    'pEnumErrors.Reset
    Set pErrInfo = pEnumErrors.Next
    If Not pErrInfo Is Nothing Then
        Debug.Print "Load completed with errors"
    Else
        Debug.Print "Load completed"
    End If
    
    
    Exit Sub
ErrorRoutine:
    Debug.Print "Load Failed: Errors: " ; Err.Number ; " " ; Err.Description
End Sub

Private Function DefaultIndexGrid(InFC As IFeatureClass) As Double
  ' Calculate approximate first grid
  ' based on the average of a random sample of feature extents times five
  Dim lngNumFeat As Long
  Dim lngSampleSize As Long
  Dim pFields As IFields
  Dim pField As IField
  Dim strFIDName As String
  Dim strWhereClause As String
  Dim lngCurrFID As Long
  Dim pFeat As IFeature
  Dim pFeatCursor As IFeatureCursor
  Dim pFeatEnv As IEnvelope
  Dim pQueryFilter As IQueryFilter
  Dim pNewCol As New Collection
  Dim lngKMax As Long
 
  Dim dblMaxDelta As Double
  dblMaxDelta = 0
  Dim dblMinDelta As Double
  dblMinDelta = 1000000000000#
  Dim dblSquareness As Double
  dblSquareness = 1
  
  Dim i As Long
  Dim j As Long
  Dim k As Long
  
  Const SampleSize = 1
  Const Factor = 1
  
  ' Create a recordset
  
  Dim ColInfo(0), c0(3)
  
  c0(0) = "minext"
  c0(1) = CInt(5)
  c0(2) = CInt(-1)
  c0(3) = False
  
  ColInfo(0) = c0
  
  lngNumFeat = InFC.FeatureCount(Nothing) - 1
  If lngNumFeat <= 0 Then
    DefaultIndexGrid = 1000
    Exit Function
  End If
  'if the feature type is points use the density function
  If InFC.ShapeType = esriGeometryMultipoint Or InFC.ShapeType = esriGeometryPoint Then
    DefaultIndexGrid = DefaultIndexGridPoint(InFC)
    Exit Function
  End If
  ' Get the sample size
  lngSampleSize = lngNumFeat * SampleSize
  ' Don't allow too large a sample size to speed
  If lngSampleSize > 1000 Then lngSampleSize = 1000
  ' Get the ObjectID Fieldname of the feature class
  Set pFields = InFC.Fields
  ' FID is always the first field
  Set pField = pFields.Field(0)
  strFIDName = pField.Name
  ' Add every nth feature to the collection of FIDs
  For i = 1 To lngNumFeat Step CLng(lngNumFeat / lngSampleSize)
    pNewCol.Add i
  Next i
  For j = 0 To pNewCol.Count - 1 Step 250
    ' Will we top out the features before the next 250 chunk?
    lngKMax = Min(pNewCol.Count - j, 250)
    strWhereClause = strFIDName + " IN("
    For k = 1 To lngKMax
      strWhereClause = strWhereClause + CStr(pNewCol.Item(j + k)) + ","
    Next k
    ' Remove last comma and add close parenthesis
    strWhereClause = Mid(strWhereClause, 1, Len(strWhereClause) - 1) + ")"
    Set pQueryFilter = New QueryFilter
    pQueryFilter.WhereClause = strWhereClause
    Set pFeatCursor = InFC.Search(pQueryFilter, True)
    Set pFeat = pFeatCursor.NextFeature
    While Not pFeat Is Nothing
      ' Get the extent of the current feature
      Set pFeatEnv = pFeat.Extent
      ' Find the min, max side of all extents. The "Squareness", a measure
      ' of how close the extent is to a square, is accumulated for later
      ' average calculation.
      dblMaxDelta = Max(dblMaxDelta, Max(pFeatEnv.Width, pFeatEnv.Height))
      dblMinDelta = Min(dblMinDelta, Min(pFeatEnv.Width, pFeatEnv.Height))
    '  lstSort.AddItem Max(pFeatEnv.Width, pFeatEnv.Height)
      If dblMinDelta <> 0 Then
        dblSquareness = dblSquareness + ((Min(pFeatEnv.Width, pFeatEnv.Height) / (Max(pFeatEnv.Width, pFeatEnv.Height))))
      Else
        dblSquareness = dblSquareness + 0.0001
      End If
      Set pFeat = pFeatCursor.NextFeature
    Wend
  Next j
  
  
  
  ' If the average envelope approximates a square set the grid size half
  ' way between the min and max sides. If the envelope is more rectangular,
  ' then set the grid size to half of the max.
  If ((dblSquareness / lngSampleSize) > 0.5) Then
    DefaultIndexGrid = (dblMinDelta + ((dblMaxDelta - dblMinDelta) / 2)) * Factor
  Else
    DefaultIndexGrid = (dblMaxDelta / 2) * Factor
  End If
End Function

Private Function Min(v1 As Variant, v2 As Variant) As Variant
  Min = IIf(v1 < v2, v1, v2)
End Function

Private Function Max(v1 As Variant, v2 As Variant) As Variant
  Max = IIf(v1 > v2, v1, v2)
End Function

Function DefaultIndexGridPoint(InFC As IFeatureClass) As Double
  ' Calculates the Index grid based on input feature class
  ' Get the dataset
  Dim pGeoDataSet As IGeoDataset
  Set pGeoDataSet = InFC
  ' Get the envelope of the input dataset
  Dim pEnvelope As IEnvelope
  Set pEnvelope = pGeoDataSet.Extent
  'Calculate approximate first grid
  Dim lngNumFeat As Long
  Dim dblArea As Double
  lngNumFeat = InFC.FeatureCount(Nothing)
  If lngNumFeat = 0 Or pEnvelope.IsEmpty Then
    ' when there are no features or an empty bnd - return 1000
    DefaultIndexGridPoint = 1000
  Else
    dblArea = pEnvelope.Height * pEnvelope.Width
    ' approximate grid size is the square root of area over the number of features
    DefaultIndexGridPoint = Sqr(dblArea / lngNumFeat)
  End If
  Set pGeoDataSet = Nothing
  Set pEnvelope = Nothing
 End Function

copyright esri comperny

系统的运行速度慢,可是能让人崩溃的哦 :)

猪头总管gis的方法也是很好的,不过如果用于数据转换处理的话会非常好,而复制效果和速度却不如ifeaturecursor.flush,我对比过这两种方法的效率,大概有700多个点要素的图层中,flush比转换的方法快了0.2秒多一点,因此数据量大时效率就会明显的比较出来的,哈哈,

以前没有处理过数据量大的数据,进公司后处理了一次,只循环检查属性就用了一整天的时间,我才开始编程时注重效率问题的,哈哈.

楼上的代码不错了,

其实esri上很多问题都是很久以后才解决的，你的问题也有类似的在esri也提过很多次，并不是一次得到解决

不过还希望大家多来这里讨论了

下面是用IFeatureConverter 在personal geodatabase中featureclass的转换

 Public Sub ConvertToGDB()
   'Make a new Name object for the input coverage...
    Dim pCoverFCName As IDatasetName
   Set pCoverFCName = New FeatureClassName
   'Make a new Name object for the output shapefile...
   Dim pAccessfcName As IDatasetName
   Set pAccessfcName = New FeatureClassName
   'Set up the input (ArcInfo) workspace...
   Dim pArcInfoWSFactory As IWorkspaceFactory
   Dim pArcInfoWS As IDataset
   Dim pArcInfoWSName As IWorkspaceName

   Set pArcInfoWSFactory = New ArcInfoWorkspaceFactory
   Set pArcInfoWS = pArcInfoWSFactory.OpenFromFile("C:\Student2\IPAO\Data\Coverages", Application.hWnd)
   Set pArcInfoWSName = pArcInfoWS.FullName
   'Set up the output (Geodatabase) workspace...
   Dim pAccessWSFactory As IWorkspaceFactory
   Dim pAccessWS As IDataset
   Dim pAccessWSName As IWorkspaceName

   Set pAccessWSFactory = New AccessWorkspaceFactory
   Set pAccessWS = pAccessWSFactory.OpenFromFile("C:\Student2\IPAO\Data\States.mdb", Application.hWnd)
   Set pAccessWSName = pAccessWS.FullName
   'Specify the filenames for the input and output datasets
   pCoverFCName.Name = "states:polygon"
   pAccessfcName.Name = "UnitedStates"
   'Set the WorkspaceName for input and output datasets
   Set pCoverFCName.WorkspaceName = pArcInfoWSName
   Set pAccessfcName.WorkspaceName = pAccessWSName
   'Use the FeatureDataConverter object to make the conversion...
   Dim pFDConverter As IFeatureDataConverter
   Set pFDConverter = New FeatureDataConverter
   pFDConverter.ConvertFeatureClass pCoverFCName, Nothing, Nothing, pAccessfcName, Nothing, Nothing, "", 1000, Application.hWnd

   MsgBox "Conversion complete", vbExclamation
End Sub
 
作者:  Jeremiah Lindemann
ESRI Educational Services

如果用featureclass.createfeature的话效率会慢好多,我已经实现了用featurecursor.flush的方法进行复制,比我上边提供的那个方法更快速,我进行过测试:现在我把我的源码发布到下面,大家共同讨论和进步:

'
'--------------------------------------------------------------------------------
' 函 数 名   :       copyFeatClsByBuffer
'功能描述:           通过特征数据集创建一个新的要素类,并通过要素类缓冲区把另一个要素类  复制中的所有地物复制到该
'                    要素类, 速度比IFeatureDataConverter的ConvertFeatureClass方法复制一个要素类速度要快,

' 参数列表   :       pFeatDataset (IFeatureDataset)'特征要素类,用于创建新的要素类
'                    sName (String)'创建的新的要素类的特征
'                    sOriFeatCls (IFeatureClass)
'--------------------------------------------------------------------------------
'
Private Sub copyFeatClsByBuffer(pFeatDataset As IFeatureDataset, sName As String, sOriFeatCls As IFeatureClass)
       '
       On Error GoTo copyFeatClsByBuffer_Err
       '
    Dim pWorkspaceEdit As IWorkspaceEdit '如果不是对网络和拓扑进行操作,IFeatureCursor.pCreatedFeatCursor.InsertFeature 不用包括在一个编辑进程里边
    Dim pCreatedFeatCls As IFeatureClass '新建的要素类
    Dim pFeatCursor As IFeatureCursor '包涵被复制的要素类中所有要素的游标
    Dim pFeat As IFeature '要素类,用于循环
    Dim pCreatedFields As IFields '新建的要素类的字段集
    Dim pCreatedFeatCursor As IFeatureCursor '用新建要素类的游标,使用该游标向新要素类中插入要素,并写入数据库
    Dim pCreatedFeatBuffer As IFeatureBuffer '新建要素类创建的要素缓冲区,
100  Set pCreatedFields = sOriFeatCls.Fields
    '创建要素类
102  Set pCreatedFeatCls = pFeatDataset.CreateFeatureClass(sName, pCreatedFields, Nothing, Nothing, esriFTSimple, "Shape", "")
    '从新建要素类中获得新游标,用于插入新的要素
104  Set pCreatedFeatCursor = pCreatedFeatCls.Insert(True)
    '创建要素缓冲区,和insert cursor 配合,创建新要素
106  Set pCreatedFeatBuffer = pCreatedFeatCls.CreateFeatureBuffer
   ' Set pWorkspaceEdit = pFeatDataset.Workspace
   '获得所有地物
108  Set pFeatCursor = sOriFeatCls.Search(Nothing, False)
110  Set pFeat = pFeatCursor.NextFeature
    Dim lIndex As Long '要素缓冲区中的字段索引
    Dim sFieldName As String '要素缓冲区中的字段的名称
    Dim iFeatCount As Integer
112  While Not pFeat Is Nothing
       iFeatCount = iFeatCount + 1
114     For lIndex = 0 To pCreatedFeatBuffer.Fields.FieldCount - 1
116          If pCreatedFeatBuffer.Fields.Field(lIndex).Editable And LCase(pCreatedFeatBuffer.Fields.Field(lIndex).Name) <> "shape" Then
118             sFieldName = pCreatedFeatBuffer.Fields.Field(lIndex).AliasName
               '给特征缓冲区中的特定字段赋值
120             pCreatedFeatBuffer.Value(lIndex) = pFeat.Value(pFeat.Fields.FindFieldByAliasName(sFieldName))
            End If
       Next
122     Set pCreatedFeatBuffer.Shape = pFeat.Shape '获得shape字段的值
       '插入要素
124     pCreatedFeatCursor.InsertFeature pCreatedFeatBuffer
126     Set pFeat = pFeatCursor.NextFeature
       If iFeatCount >= 2000 Then '每二千个要素就把缓冲区内的要素类写入数据库
       pCreatedFeatCursor.Flush
       iFeatCount = 0
       End If
    Wend
128  pCreatedFeatCursor.Flush
       '
       Exit Sub

copyFeatClsByBuffer_Err:
       MsgBox Err.Description ; vbCrLf ; _
              "在 函数copyFeatClsByBuffer 中的第" ; Erl ; "行出错"
       Resume Next
       '
End Sub

我觉得大家讨论的气氛不是很好,我在esri论坛发这样的帖子,很快就有人回复并进行了讨论.

我用过featureclass.createfeature的方法来建立新要素,来进行粘贴

方法应该是多样的:)

哈哈,很好的问题,希望大虾们涌跃的讨论呀