Le portail francophone de la géomatique

Public Sub test2()
    Dim pmxdoc As IMxDocument
    Set pmxdoc = ThisDocument
    Dim pmap As IMap
    Set pmap = pmxdoc.FocusMap
    Dim player As ILayer
    
    'récupération de la couche souhaitée dans le bloc de données
    Set player = pmap.Layer(0)
    Dim pfl As IFeatureLayer
    
    'si elle de type vectorielle (vérification)
    If TypeOf player Is IFeatureLayer Then
        Set pfl = player
        Dim pfc As IFeatureClass
        Set pfc = pfl.FeatureClass

        'si le champ indice existe on le supprime
        If pfc.FindField("indice") <> -1 Then
            pfc.DeleteField pfc.Fields.Field(pfc.FindField("indice"))
        End If

        Dim pindicefld As IFieldEdit
        Set pindicefld = New Field
        
        'création d'un nouveau champ recueillant le résultat
        With pindicefld
            .Name = "indice"
            .Type = esriFieldTypeDouble
        End With
        
        pfc.AddField pindicefld
        
        Dim pfcursor As IFeatureCursor
        Set pfcursor = pfc.Search(Nothing, True)
        Dim pfeature As IFeature
        Set pfeature = pfcursor.NextFeature
        Dim pcurve As ICurve
        Dim pline As ILine
        
        'tant qu'il y a une entité dans la table des cours d'eau
        Do Until pfeature Is Nothing
            'récupération du cours d'eau
            Set pcurve = pfeature.Shape
            'vérification facultative sur la longueur du cours d'eau
            If Not pcurve.Length = 0 Then
                Set pline = New Line
                'création d'une ligne droite avec le point de départ et le point d'arrivée
                pline.FromPoint = pcurve.FromPoint
                pline.ToPoint = pcurve.ToPoint
                'calcul de l'indice
                pfeature.Value(pfc.FindField("indice")) = pcurve.Length / pline.Length
                'sauvegarde de l'indice dans le champ créé précédemment
                pfeature.Store
            End If
            
            Set pfeature = pfcursor.NextFeature
        Loop
        
    Else
        Exit Sub
    End If
            
End Sub