Le portail francophone de la géomatique

Bonjour,

Si tu n’as toujours pas trouvé de solution, je te propose d’utiliser la
routine suivante.

Procédure de mise en marche :
Code à coller dans Visual Basic Editeur d’ArcMap
Outils > Macros > Macro > Choisir le nom de la macro a exécuté dans la
liste
Attention cette routine ne fonctionne que sur la première couche de la
TOC

En espérant que cela puisse t’aider.

Public Sub CréationEmpriseLayer()
' Nom: CréationEmpriseLayer
' Création: frederic.prally@texte-a-enlever.setegue.fr
' Date: 31/08/2005
' Description: Affiche l'emprise des entités sélectionnées d'une couche
de type Ifeaturelayer

    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    Dim pLayer As ILayer
    Dim pFeatureLayer As IFeatureLayer
    Dim pFSelection As IFeatureSelection
    Dim pFCursor As IFeatureCursor
    Dim pEnvelope As IEnvelope
    Dim pTotalEnvelope As IEnvelope
   
    Set pMxDoc = ThisDocument
    Set pMap = pMxDoc.FocusMap
    Set pLayer = pMap.Layer(0)
   
    'Vérifie que la couche est bien de t ype IfeatureLayer
    If Not TypeOf pLayer Is IFeatureLayer Then
        MsgBox "Veuillez sélectionner une couche de type FeatureLayer."
_
        , vbExclamation, "Recherche emprise"
        Exit Sub
    End If
   
    Set pFeatureLayer = pLayer 'QI
   
    'Part 1 : Définition des entités sélectionnés
    Set pFSelection = pFeatureLayer
    If pFSelection.SelectionSet.count = 0 Then
        MsgBox "Veuillez sélectionner des entités sur la couche " &
pLayer.Name & "." _
        , vbExclamation, "Recherche emprise"
        Exit Sub
    End If
   
    pFSelection.SelectionSet.Search Nothing, False, pFCursor
   
    Dim pFeature As IFeature
    Set pFeature = pFCursor.NextFeature
    Set pTotalEnvelope = New Envelope
   
    'Récupérer l'étendue globale de la couche par union des emprises des
entités
    Do Until pFeature Is Nothing
            Set pEnvelope = pFeature.Shape.Envelope
            pTotalEnvelope.Union pEnvelope
    Set pFeature = pFCursor.NextFeature
    Loop
    'Part 2 : Appel de la procédure servant à créer un polygone
    Call AddGraphicPolygon(pTotalEnvelope)
End Sub

Public Sub AddGraphicPolygon(pMonEnvelope As IEnvelope)
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
   
    'Création d'un polygon via les coordonnées de l'enveloppe
    Dim pPointCollection As IPointCollection
    Set pPointCollection = New Polygon
    Dim pEnvelope As IEnvelope
    Set pEnvelope = pMonEnvelope
    With pPointCollection
        .AddPoint pEnvelope.LowerLeft
        .AddPoint pEnvelope.UpperLeft
        .AddPoint pEnvelope.UpperRight
        .AddPoint pEnvelope.LowerRight
    End With

     'Création de l'élément graphique de forme rectangulaire
    Dim pGraphCont As IGraphicsContainer
    Set pGraphCont = pMxDoc.ActiveView
    Dim pElement As IElement
    Set pElement = New PolygonElement
    pElement.Geometry = pPointCollection
    Dim pFillElement As IFillShapeElement
    Set pFillElement = pElement
    pFillElement.Symbol.Color.NullColor = True
    pGraphCont.AddElement pElement, 0
   
    'Rafraichit la page active
    pMxDoc.ActiveView.Refresh

End Sub

__________________________________
PRALLY Frédéric



Cartographie et SIG

53, rue Charles Frérot - B.P.91
94253 Gentilly Cedex
Tél : 01.41.98.68.00

  frederic.prally@texte-a-enlever.setegue.fr