阅读:1474回复:1
如何合并含有Z值的要素?
<P>Private Sub ConstructUnion()
On Error GoTo ErrorHandler</P> <P> Dim pMxDoc As IMxDocument Dim pMap As IMap Set pMxDoc = Application.Document Set pMap = pMxDoc.FocusMap Dim pFeatureLayer As IFeatureLayer Dim pFeatureSelection As IFeatureSelection Dim pSelectionSet As ISelectionSet Dim pFeature As IFeature Dim pEnumFeature As IEnumFeature Dim pGeoDataset As IGeoDataset Dim pSpatialRef As ISpatialReference Dim pGeoBag As IGeometryCollection Dim pGeometry As IGeometry Dim pTopoOp As ITopologicalOperator2 Dim pGeometryTemp As IGeometry Dim lGeometryType As Long Dim pTopoOpSimplify As ITopologicalOperator2 Dim pWKS As IWorkspace Dim pWKSE As IWorkspaceEdit Dim bInOperation As Boolean Dim DeletedFeatureCount As Integer Dim pDataset As IDataset Dim pFeatureCursor As IFeatureCursor Dim iCount As Integer For iCount = 1 To pMap.LayerCount Set pFeatureLayer = pMap.Layer(iCount - 1) Set pDataset = pFeatureLayer Set pWKS = pDataset.Workspace Set pWKSE = pWKS 'Check if feature layer is editable If pFeatureLayer.Visible And pWKSE.IsBeingEdited Then pWKSE.StartEditOperation bInOperation = True Set pFeatureSelection = pFeatureLayer Set pSelectionSet = pFeatureSelection.SelectionSet 'Check if there is a selection If Not pSelectionSet.Count = 0 Then pSelectionSet.Search Nothing, False, pFeatureCursor Set pFeature = pFeatureCursor.NextFeature If pFeature Is Nothing Then MsgBox "必须选择至少一个要素!" Exit Sub End If '设置保存合并的要素 Dim pFeatureBuffer As IFeatureBuffer Dim pInFCur As IFeatureCursor, q As Long Dim pInFeat As IFeature Dim pFC As IFeatureClass Set pFC = pFeatureLayer.FeatureClass Set pFeatureBuffer = pFC.CreateFeatureBuffer Set pInFCur = pFC.Insert(True) Set pInFeat = pFeatureBuffer Set pInFeat = pFeature Set pGeoDataset = pFeature.Class 'Get the spatial reference of the first feature in the enumerator Set pSpatialRef = pGeoDataset.SpatialReference Set pGeoBag = New GeometryBag 'Set the spatial reference of the geometryBag via IGeometry Set pGeometry = pGeoBag 'QI Set pGeometry.SpatialReference = pSpatialRef Set pGeometryTemp = pFeature.ShapeCopy 'Set the value of the Union GeometryType lGeometryType = pGeometryTemp.GeometryType Do While Not pFeature Is Nothing 'Add only the geometry with the same geometrytype than the one determined earlier If pFeature.ShapeCopy.GeometryType = lGeometryType Then pGeoBag.AddGeometry pFeature.ShapeCopy End If Set pFeature = pFeatureCursor.NextFeature Loop '创建一个新的geometry Select Case lGeometryType Case esriGeometryPoint Set pTopoOp = New Multipoint Case esriGeometryMultipoint Set pTopoOp = New Multipoint Case esriGeometryPolyline Set pTopoOp = New Polyline Case esriGeometryPolygon Set pTopoOp = New Polygon Case Else Exit Sub End Select pTopoOp.ConstructUnion pGeoBag '插入要素的shape到pInFCur Set pInFeat.Shape = pTopoOp /出错提示:这个几何没有Z值 q = pInFCur.InsertFeature(pInFeat) pInFCur.Flush '删除原来的要素 pSelectionSet.Search Nothing, False, pFeatureCursor Set pFeature = pFeatureCursor.NextFeature Do While Not pFeature Is Nothing pFeature.Delete DeletedFeatureCount = DeletedFeatureCount + 1 Set pFeature = pFeatureCursor.NextFeature Loop If DeletedFeatureCount = 0 Then pWKSE.AbortEditOperation Else pWKSE.StopEditOperation bInOperation = False End If End If End If Next pMxDoc.ActiveView.Refresh Exit Sub ErrorHandler: MsgBox Err.Description If bInOperation Then pWKSE.AbortEditOperation End If End Sub</P> |
|
1楼#
发布于:2004-08-31 16:43
有空看看,帮顶下。哈。。
|
|
|