Archived Forums

Option Explicit
Sub Test()
    '
    ' tested with the parcels shapefile from
    'D:\arcgis\arcexe83\ArcObjects Developer Kit\Samples\Data\Greeley
    ' in the maptopolgy, with the topology already built
    '
    Dim pTopoExt As ITopologyExtension
    Set pTopoExt = Application.FindExtensionByName("ESRI Topology Extension")
    If pTopoExt.MapTopology.ClassCount <> 1 Then
        MsgBox "put just one featureclass in the maptopology"
        Exit Sub
    End If
    
    Dim pFC As IFeatureClass
    Set pFC = pTopoExt.MapTopology.Class(0)
    If pFC.ShapeType <> esriGeometryPolygon Then
        MsgBox "featurclass must be polygon"
        Exit Sub
    End If
        
    Debug.Print "getting percentages ..."
    Dim pDict As Scripting.Dictionary
    Set pDict = GetPercentages(pTopoExt.MapTopology.Cache, pFC)
    If pDict Is Nothing Then Exit Sub
    
    Dim lOIDs() As Long, l As Long, vOID As Variant
    ReDim lOIDs(pDict.Count - 1)
    l = 0
    For Each vOID In pDict.Keys
        lOIDs(l) = vOID
        l = l + 1
    Next vOID
    
    Dim lFld As Long
    lFld = pFC.FindField("OID_") ' just a junk field
    If lFld = -1 Then
        MsgBox "field not found"
        Exit Sub
    End If
    
    Dim pEditor As IEditor
    Set pEditor = Application.FindExtensionByName("ESRI Object Editor")
    pEditor.StartOperation
    
    Dim pFCur As IFeatureCursor
    Set pFCur = pFC.GetFeatures(lOIDs, False)
    
    Dim pFeat As IFeature
    Set pFeat = pFCur.NextFeature
    Do Until pFeat Is Nothing
        pFeat.Value(lFld) = pDict.Item(pFeat.OID)
        pFeat.Store
        Set pFeat = pFCur.NextFeature
    Loop
    pEditor.StopOperation "percent perimeter"
End Sub

Function GetPercentages(pTopoGraph As ITopologyGraph, _
                        pFC As IFeatureClass) As Scripting.Dictionary
    '
    ' for each feature, determine the percentage of its
    ' perimeter that doesn't abutt onto another polygon.
    '
    Dim pDict As New Scripting.Dictionary
        
    Dim pFCur As IFeatureCursor
    Set pFCur = pFC.Search(Nothing, False)
    
    Dim pFeat As IFeature
    Set pFeat = pFCur.NextFeature
    Do Until pFeat Is Nothing
        
        Dim dLen As Double
        dLen = 0#
        
        Dim pEnumEdge As IEnumTopologyEdge
        Set pEnumEdge = pTopoGraph.GetParentEdges(pFC, pFeat.OID)
        If Not pEnumEdge Is Nothing Then
            Dim pTopoEdge As ITopologyEdge
            Set pTopoEdge = pEnumEdge.Next
            Do Until pTopoEdge Is Nothing
                If pTopoEdge.Parents.Count = 1 Then
                    dLen = dLen + GetLength(pTopoEdge.Geometry)
                End If
                Set pTopoEdge = pEnumEdge.Next
            Loop
            pDict.Add pFeat.OID, dLen / GetLength(pFeat.Shape) * 100
        Else
            Debug.Print "no edges found for polygon " & pFeat.OID
        End If
        Set pFeat = pFCur.NextFeature
    Loop
    If pDict.Count > 0 Then
        Set GetPercentages = pDict
    Else
        MsgBox " no edges found, maybe try building first"
    End If
End Function

Function GetLength(pCurve As ICurve) As Double
    GetLength = pCurve.Length
End Function