ArcGIS Topology——自动处理细小缝隙

public const m_GapTolerance =1 '(1平方米)

Private Sub ValidateGaps()

     Dim pMxDoc As IMxDocument

    Set pMxDoc = ThisDocument

    Dim pTopolayer As ITopologyLayer

    Set pTopolayer = pMxDoc.FocusMap.Layer(0) '//第一层为拓扑层

    Dim pTopology As ITopology

    Set pTopology = pTopolayer.Topology

    Dim pTopoErrCon As IErrorFeatureContainer

    Set pTopoErrCon = pTopology

    Dim pEnumtopoErrorFeature As IEnumTopologyErrorFeature

    Dim pTopoRuleCon As ITopologyRuleContainer

    Set pTopoRuleCon = pTopology

    Dim pTopologyRule As ITopologyRule

    Dim pFeatureClass As IFeatureClass

    Dim pDs As IDataset

    Dim pFeatureWs As IFeatureWorkspace

    Set pDs = pTopology

    Set pFeatureWs = pDs.Workspace

    '//某图层

  

    Dim pFL As IFeatureLayer

    Set pFL = pMxDoc.FocusMap.Layer(1) '//第二层为宗地面层

    Set pFeatureClass = pFL.FeatureClass

    If pFeatureClass Is Nothing Then Exit Sub

   

    Dim pEnumRule As IEnumRule

    Set pEnumRule = pTopoRuleCon.Rules

    pEnumRule.Reset

    Set pTopologyRule = pEnumRule.Next

    Do While Not pTopologyRule Is Nothing

        If pTopologyRule.TopologyRuleType = esriTRTAreaNoGaps Then Exit Do

        Set pTopologyRule = pEnumRule.Next

    Loop

    If pTopologyRule Is Nothing Then Exit Sub

    '//获得JZM不能自相重叠的拓扑错误

    Dim pGeoDs As IGeoDataset

    Set pGeoDs = pTopology

    Set pEnumtopoErrorFeature = pTopoErrCon.ErrorFeatures(pGeoDs.SpatialReference, pTopologyRule, pGeoDs.Extent, True, False)

    Dim pTopoErrorFeature As ITopologyErrorFeature

    Set pTopoErrorFeature = pEnumtopoErrorFeature.Next

    Dim pFeature As IFeature

    '//拓扑错误的相关要素

    Dim pSFeature As IFeature

    Dim pDFeature As IFeature

    Dim pArea1 As IArea

    Dim pArea2 As IArea

    Dim pArea3 As IArea

    Dim lFldZDH As Long '//宗地号

    Dim lFldJSZDMJ As Long '//计算宗地面积

    Dim lFldSJYT As Long

    '//更新提示信息

  

    DoEvents

    Dim lngLoop As Long

    Dim lngCount As Long

    On Error GoTo NEXTFEATURE

    Dim pSpatialFilter As ISpatialFilter

    Set pSpatialFilter = New SpatialFilter

   

    Dim pFeatureCursor As IFeatureCursor

   

    Dim dblLength As Double

    Dim pTopologicalOperator As ITopologicalOperator2

    Dim pPolyLine As IPolyline

    Dim pPolygon As IPointCollection

    Set pPolygon = New Polygon

    Dim pWsEdit As IWorkspaceEdit

    Set pWsEdit = pDs.Workspace

    pWsEdit.StartEditing True

    pWsEdit.StartEditOperation

    Set pTopoRuleCon = pTopology

    Do While Not pTopoErrorFeature Is Nothing

        Set pFeature = pTopoErrorFeature

        Set pPolygon = New Polygon

        pPolygon.AddPointCollection pFeature.ShapeCopy

        Dim pPoly As IPolygon

        Set pPoly = pPolygon

        pPoly.Close

        Set pPolygon = pPoly

        If (TypeOf pPolygon Is IArea) Then

            Set pTopologicalOperator = pPolygon

            pTopologicalOperator.IsKnownSimple = False

            pTopologicalOperator.Simplify

            Set pPolygon = pTopologicalOperator

            '//首先如果该拓扑错误包含要素,则作为例外处理

            Set pSpatialFilter.Geometry = pPolygon

            pSpatialFilter.SpatialRel = esriSpatialRelContains

           

            Set pFeatureCursor = pFeatureClass.Search(pSpatialFilter, False)

            Set pSFeature = Nothing

            Set pSFeature = pFeatureCursor.NEXTFEATURE

            If Not pSFeature Is Nothing Then

                pTopoRuleCon.PromoteToRuleException pTopoErrorFeature

                GoTo NEXTFEATURE

            End If

            Set pArea3 = pPolygon

            '//活着很下场

            Dim pCurve As ICurve

            Set pCurve = pPolygon

            If pArea3.Area = 0 Then

                pTopoRuleCon.PromoteToRuleException pTopoErrorFeature

                GoTo NEXTFEATURE

            End If

            If Abs(pArea3.Area) <= m_GapTolerance Or Abs(pCurve.Length / pArea3.Area) > 5 Then '//在1平方米内的自动处理

                '//获得与该要素相邻数据

                '//空间搜索标准

                pSpatialFilter.SpatialRel = esriSpatialRelTouches '//共界

                Set pSpatialFilter.Geometry = pTopologicalOperator

                pSpatialFilter.WhereClause = "mid(zdh,5,1) ='9'"

                Set pFeatureCursor = pFeatureClass.Search(pSpatialFilter, False)

                Set pSFeature = pFeatureCursor.NEXTFEATURE

                '//获取公共部分

                dblLength = 0

                Set pDFeature = Nothing

                Do While Not pSFeature Is Nothing

                    Set pTopologicalOperator = pFeature.ShapeCopy

                    Set pPolyLine = pTopologicalOperator.Intersect(pSFeature.ShapeCopy, esriGeometry1Dimension)

                    If dblLength < pPolyLine.Length Then

                        dblLength = pPolyLine.Length

                        Set pDFeature = pSFeature

                    End If

                    Set pSFeature = pFeatureCursor.NEXTFEATURE

                Loop

                '//将裂隙对象付给最大的块地

                If pDFeature Is Nothing Then GoTo NEXTFEATURE

                Dim pGeometry As IGeometry

                Dim pAimPolygon As IPolygon

                Set pAimPolygon = pPolygon

                pAimPolygon.Close

                Set pTopologicalOperator = pAimPolygon

                pTopologicalOperator.IsKnownSimple = False

                pTopologicalOperator.Simplify

                Set pTopologicalOperator = pDFeature.ShapeCopy

                pTopologicalOperator.IsKnownSimple = False

                pTopologicalOperator.Simplify

                Set pGeometry = pTopologicalOperator.Union(pAimPolygon)

                Set pDFeature.Shape = pGeometry

                pDFeature.Store

            Else '//不能处理的部分

            End If

           

        End If

       

       

        If lngLoop Mod 10 = 0 Then

            DoEvents

           ' FrmProGress.ProgressBar.Value = IIf(FrmProGress.ProgressBar.Value + 1 > FrmProGress.ProgressBar.Max, 1, FrmProGress.ProgressBar.Value + 1)

        End If

        If lngLoop Mod 100 = 0 Then

            pWsEdit.StopEditOperation

            pWsEdit.StopEditing True

            pWsEdit.StartEditing False

            pWsEdit.StartEditOperation

        End If

       

NEXTFEATURE:

        Err.Clear

        lngLoop = lngLoop + 1

        Set pTopoErrorFeature = pEnumtopoErrorFeature.Next

    Loop

    DoEvents

   

    '//刷新界面

   

    Exit Sub

PROC_ERR:

    MsgBox "自动处理缝隙错误:" & Err.Description

End Sub