This script was used to transfer an attribute from aggregated polygons based to the original (and more numerous) original polygons.
Public Sub transferAttributesBasedOnLabelPointContainment()
Dim pMxDoc As IMxDocument Dim pMap As IMap Set pMxDoc = ThisDocument Set pMap = pMxDoc.FocusMap
Dim pSrcLayer As IFeatureLayer Dim pSrcFeatureClass As IFeatureClass Dim pSrcFeatureCursor As IFeatureCursor Dim pSrcFeature As IFeature Dim ptarLayer As IFeatureLayer Dim pTarFeatureClass As IFeatureClass Dim pTarFeatureCursor As IFeatureCursor Dim pTarFeature As IFeature Dim intGeometry As IGeometry
Dim pQF As ISpatialFilter Dim ptararea As IArea Dim pTO As ITopologicalOperator Set pSrcLayer = pMap.Layer(1) Set pSrcFeatureClass = pSrcLayer.FeatureClass Set ptarLayer = pMap.Layer(0) Set pTarFeatureClass = ptarLayer.FeatureClass
Set pSrcFeatureCursor = pSrcLayer.Search(Nothing, True) Set pSrcFeature = pSrcFeatureCursor.NextFeature
'iterate through quad features (which are all polygons with 5 points) Do Until pSrcFeature Is Nothing
Set pQF = New SpatialFilter pQF.WhereClause = "" pQF.SpatialRel = esriSpatialRelIntersects Set pQF.Geometry = pSrcFeature.Shape
Set pTarFeatureCursor = ptarLayer.Search(pQF, True) Set pTarFeature = pTarFeatureCursor.NextFeature
Do Until pTarFeature Is Nothing Set ptararea = pTarFeature.Shape Set pTO = ptararea.LabelPoint Set intGeometry = pTO.Intersect(pSrcFeature.Shape, esriGeometryNoDimension) If Not intGeometry.IsEmpty Then pTarFeature.Value(pTarFeatureClass.FindField("HealthSA")) = CLng(pSrcFeature.Value(pSrcFeatureClass.FindField("NAME"))) pTarFeature.Store End If Set pTarFeature = pTarFeatureCursor.NextFeature Loop Set pSrcFeature = pSrcFeatureCursor.NextFeature Loop
