Le portail francophone de la géomatique

Public Sub SelectPointinPolygon_TransfertAttr()
'***Pour chaque point compris dans un polygone, on récupère les valeurs du point pour les coller dans le polygone
'***Vérifier que le champ qui doit recevoir les valeurs existe bien
'***Changer le nom des champs des constantes


' ---- Changer le nom du champ ----
Const FROM_FIELD = "Description"
Const TO_FIELD = "Description"
' -------------------------------
    'Déclaration des variables générales
    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    
    'Déclaration des variables pourtant sur les deux couches de travail
    Dim pPointFLayer As IFeatureLayer
    Dim pPolygonFLayer As IFeatureLayer
    Dim pPointFC As IFeatureClass
    Dim pPolygonFC As IFeatureClass
    Dim pPointFCursor As IFeatureCursor
    Dim pPolyFCursor As IFeatureCursor
    Dim pPoint As IFeature
    Dim pPoly As IFeature
    
    'Initialisation des variables
    Set pMxDoc = ThisDocument
    Set pMap = pMxDoc.FocusMap
    
    Set pPointFLayer = pMap.Layer(0)   '------------Couche de points en 1ère position ds TOC
    Set pPolygonFLayer = pMap.Layer(1) '------------Couche de polygones en 2ème position ds TOC
    
    Set pPointFC = pPointFLayer.FeatureClass
    Set pPolygonFC = pPolygonFLayer.FeatureClass
    
    'Recupére un cursor sur la couche de points
    Set pPointFCursor = pPointFC.Search(Nothing, False)
    Set pPoint = pPointFCursor.NextFeature
        
    'Préparation de la Status bar
    Dim pStatusBar As IStatusBar
    Dim pProgressBar As IStepProgressor
    Dim ltotalVal As Long
    
    Set pStatusBar = ThisDocument.Parent.StatusBar
    Set pProgressBar = pStatusBar.ProgressBar
    pProgressBar.Position = 0
    ltotalVal = pPointFC.FeatureCount(Nothing)
    pStatusBar.ShowProgressBar "Processus en cours ...", 0, ltotalVal, 1, True
    
    'Boucle sur chaque point, et selectionne le polygone intersecté
    'et copie les valeurs du champ point vers polygone
    Do Until pPoint Is Nothing
        'Définition de la requête spatiale
        Dim pFilter As ISpatialFilter
        Set pFilter = New SpatialFilter
        
        With pFilter
            Set .Geometry = pPoint.Shape
            .GeometryField = pPolygonFC.ShapeFieldName
            .SpatialRel = esriSpatialRelIntersects
        End With
        
        Set pPolyFCursor = pPolygonFC.Search(pFilter, False)
        Set pPoly = pPolyFCursor.NextFeature
        'Transfert de valeurs du polygone vers le point
        'Ajout les valeurs du champ point au champ du polygone intersecté
        's'il y a plusieurs valeurs les valeurs sont séparées par ", "
            
        Do While Not pPoly Is Nothing
            If pPoly.Value(pPolygonFC.FindField(TO_FIELD)) <> "" Then
                pPoly.Value(pPolygonFC.FindField(TO_FIELD)) = pPoly.Value(pPolygonFC.FindField(TO_FIELD)) _
                                                            & ", " & pPoint.Value(pPointFC.FindField(FROM_FIELD))
                pPoly.Store
            Else
                pPoly.Value(pPolygonFC.FindField(TO_FIELD)) = pPoint.Value(pPointFC.FindField(FROM_FIELD))
                pPoly.Store
            End If
            
            pStatusBar.StepProgressBar
            Set pPoly = pPolyFCursor.NextFeature
        Loop
        Set pPoint = pPointFCursor.NextFeature
    Loop
    pStatusBar.HideProgressBar
    
    'Vide les variables
    Set pStatusBar = Nothing
    Set pProgressBar = Nothing

End Sub