Le portail francophone de la géomatique

Public Sub CouleurEtiquetteIdentiqueEntite()
'Description : Applique la même couleur des entités représentées aux classes d'étiquettes créées
'Limitation  : il faut que les entités de la couche soit représentée en valeur unique
'Auteur : F. Prally
'Date   : Janvier 2006
    Dim pMxDocument As IMxDocument
    Dim pFeatureLayer As IFeatureLayer
    Dim pGeoLayer As IGeoFeatureLayer
    Dim pRenderer As IFeatureRenderer
    Dim pUVRenderer As IUniqueValueRenderer
    Dim pAnnoPropsCollection As IAnnotateLayerPropertiesCollection
    Dim pLabelEngine As ILabelEngineLayerProperties
    Dim pALayerProperties As IAnnotateLayerProperties
    Dim pTextSym As ITextSymbol
    Dim pFont As IFontDisp
    Dim sValue As String
    Dim MyLayer As String, sLabelField As String
    Dim i As Long, j As Long
    Dim pSymbol As ISymbol
    Dim pLineSymbol As ILineSymbol
    Dim pColor As IColor
    Dim pRgbColor As IRgbColor
    Dim sNameClass As String
    
    Set pMxDocument = ThisDocument
    
    'Récupére le nom de la couche
    MyLayer = InputBox("Saisir le nom de la couche :", "Couleur étiquetage identique entité")
    If MyLayer = "" Then Exit Sub
    Set pFeatureLayer = GetLayer(MyLayer)
    Set pGeoLayer = pFeatureLayer
    
    'Test si on a bien à faire UniqueValueRenderer
    If Not TypeOf pGeoLayer.Renderer Is IUniqueValueRenderer Then
        MsgBox "Veuillez représenter votre couche en valeur unique.", vbInformation
        Exit Sub
    End If
    
    'Récupére le renderer de la couche
    Set pUVRenderer = pGeoLayer.Renderer
    Set pRenderer = pGeoLayer.Renderer
    
    'Identification du champ devant servir à l'étiquetage
    sLabelField = pUVRenderer.Field(FieldValue)
    
    '***Part 2 : Affichage des annotations
    'Définition des propriétés des étiquettes
    Set pAnnoPropsCollection = pGeoLayer.AnnotationProperties
    pAnnoPropsCollection.Clear
    'Pour chaque valeur on crée une classe d'étiquettes
    For j = 0 To pUVRenderer.ValueCount - 1
    
        Set pLabelEngine = New LabelEngineLayerProperties
        Set pALayerProperties = pLabelEngine
        
        'Récupère le nom de la classe
        sNameClass = pUVRenderer.Value(j)
        
        'Création de la classe
        pALayerProperties.Class = sNameClass
        
        'Récupère la couleur du symbole
        Set pLineSymbol = pUVRenderer.Symbol(sNameClass)
        Set pColor = pLineSymbol.Color
        Set pRgbColor = New RgbColor
        pRgbColor.RGB = pColor.RGB

        'Création de la requete SQL
        pALayerProperties.WhereClause = "[" & sLabelField & "]=" & sNameClass
        Set pLabelEngine = pALayerProperties
        
        'Supprime l'expression précédente
        pLabelEngine.Expression = ""
        
        'Ecriture du champ de l'étiquette
        pLabelEngine.Expression = "[" & sLabelField & "]"
        
        'Applique la couleur à l'étiquette
        Set pTextSym = New TextSymbol
        pTextSym.Color = pRgbColor
        Set pFont = New StdFont
        With pFont
            .Bold = True
            .size = 12
        End With
        Set pLabelEngine.Symbol = pTextSym
        
        'Valider les propriétés d'étiquetage
        pAnnoPropsCollection.Add pALayerProperties
        
        'Valide l'étiquetage de cette classe
        pALayerProperties.DisplayAnnotation = True
    Next j
    
    'N'affiche pas la classe toutes les valeurs
    Dim k As Long
    For k = 0 To pAnnoPropsCollection.Count - 1
        pAnnoPropsCollection.QueryItem k, pALayerProperties
        Select Case pALayerProperties.Class
        Case "<Toutes les autres valeurs>"
            pALayerProperties.DisplayAnnotation = False
        Case "Par défaut"
            pALayerProperties.DisplayAnnotation = False
        End Select
    Next k
    
    'Valide l'étiquetage de cette couche
    pGeoLayer.DisplayAnnotation = True
    
    'Rafraichissement des vues
    pMxDocument.ActiveView.Refresh
    
    'Vide les variables
    Set pMxDocument = Nothing
    Set pFeatureLayer = Nothing
    Set pGeoLayer = Nothing
    Set pRenderer = Nothing
    Set pUVRenderer = Nothing
    Set pAnnoPropsCollection = Nothing
    Set pLabelEngine = Nothing
    Set pALayerProperties = Nothing
    Set pTextSym = Nothing
    Set pSymbol = Nothing
    Set pLineSymbol = Nothing
    Set pColor = Nothing
    Set pRgbColor = Nothing
    
End Sub

Public Function GetLayer(strLayerName As String, Optional pMap As IMap = Nothing) As ILayer
  If pMap Is Nothing Then
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
    Set pMap = pMxDoc.FocusMap
  End If
  Dim pLayer As ILayer
  Dim i As Integer
  For i = 0 To pMap.LayerCount - 1
    Set pLayer = pMap.Layer(i)
    If pLayer.Name = strLayerName Then
      Set GetLayer = pLayer
      Exit Function
    End If
  Next
  Set GetLayer = Nothing
End Function

Une ou plusieurs couches n'ont pas été dessinées:

FDO error: 0 [L'étiquetage de la couche HYDROMM pour la classe II0002 a échoué.