ArcMap中对面状要素的重叠检查和标识，VBA编码

Private Sub 地块重叠检查_Click()

    Dim pMxDoc As IMxDocument
    Dim pGraphicsContainer As IGraphicsContainer
    Dim pActiveView As IActiveView

    Set pMxDoc = Application.Document
    Set pGraphicsContainer = pMxDoc.FocusMap
    Set pActiveView = pMxDoc.FocusMap
    
    
    Dim pMap                    As IMap
    Dim pFeaturelayer           As IFeatureLayer
    Dim pFeatureclass           As IFeatureClass
    
    Set pMap = pMxDoc.FocusMap
    Set layer = pMap.layer(0)
    Set pFeaturelayer = layer
    Set pFeatureclass = pFeaturelayer.FeatureClass

     
    Dim pColor As IRgbColor
    Set pColor = New RgbColor
    pColor.Red = 255
    pColor.Green = 0
    pColor.Blue = 0

    '先设置线符号样式
    Dim pSLS1 As ISimpleLineSymbol
    Set pSLS1 = New SimpleLineSymbol
    pSLS1.Color = pColor
    pSLS1.Width = 5

    '设置面线符号样式
    Dim pSFillSymbol As ISimpleFillSymbol
    Set pSFillSymbol = New SimpleFillSymbol
    
    With pSFillSymbol
        .Color = pColor
        .Style = esriSFSNull
        .Outline = pSLS1  '。
    End With
   
    Dim pFillShapeElement As IFillShapeElement
    Dim pElement As IElement
    Dim pPolygon As IPolygon
    
    Dim pCollection As VBA.Collection
    Set pCollection = New Collection
    
    Dim pFeature                As IFeature
    Dim pFeatureCursor          As IFeatureCursor
    Set pFeatureCursor = pFeatureclass.Search(Nothing, False)
    Set pFeature = pFeatureCursor.NextFeature
    
    Dim pRelationalOperator As IRelationalOperator
    Dim pTopologicalOperator  As ITopologicalOperator
     
    Do While Not pFeature Is Nothing
        pCollection.Add pFeature.OID
        Set pFeature = pFeatureCursor.NextFeature
    Loop
   
    Dim pFeature1 As IFeature
    Dim pFeature2 As IFeature
    Dim pArea As IArea
    Dim i, j As Integer
    
    CheckResult.ListBox1.Clear
    
    If pFeatureclass.ShapeType = esriGeometryPolygon Then
    
        For i = 1 To pCollection.count
           
           Set pFeature1 = pFeatureclass.GetFeature(pCollection.Item(i))
           
           For j = i + 1 To pCollection.count
              
               Set pFeature2 = pFeatureclass.GetFeature(pCollection.Item(j))
            
               Set pRelationalOperator = pFeature1.ShapeCopy
               
               If pRelationalOperator.Overlaps(pFeature2.ShapeCopy) Then
               
                     Set pTopologicalOperator = pFeature1.Shape

                     Set pPolygon = pTopologicalOperator.Intersect(pFeature2.ShapeCopy, esriGeometry2Dimension)
                     
                     Set pArea = pPolygon
                     
                     Set pFillShapeElement = New PolygonElement
                     Set pElement = pFillShapeElement

                     pFillShapeElement.Symbol = pSFillSymbol
                     pElement.Geometry = pPolygon
              
                     pGraphicsContainer.AddElement pElement, 0
                     
                     CheckResult.ListBox1.AddItem "图层_" & pFeatureclass.AliasName & "_中OID=" & pFeature1.OID & "和OID=" & pFeature2.OID & "之间存在重叠，重叠面积：" & Round(pArea.Area, 6) & " 平方米"
                  
               End If
               
           Next j
           
        Next i
        
     End If
     
     pActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing
     
     If CheckResult.ListBox1.ListCount = 0 Then
        MsgBox "地块之间不存在重叠！"
     Else
        CheckResult.Show
     End If

End Sub