XL 2010 Mettre une couleur de remplissage dans un "Label"

[Magic_Doctor]

Bonjour,

Dans ma feuille j'ai un "Label".
Je voudrais que la couleur de remplissage de celui-ci soit la même que celle d'une cellule.
Pour y parvenir, autant que faire se peut (...), j'ai bidouillé le truc suivant :
1/ je récupère, en code hexadécimal, la couleur de remplissage de la cellule :

Function HexaColor(Target As Range, Optional fond As Integer) As String
'Renvoie le code hexadécimal d'une couleur
'Lone-wolf
'---- 0 ou absence du 2eme argument renvoie la couleur de remplissage
'---- tout autre nombre renvoie la couleur de la police
'---- renvoi la couleur par défaut hors Mise En Forme Conditionnelle

    Application.Volatile
    If fond = 0 Then
        HexaColor = "&" & Application.Dec2Hex(Target.Interior.Color, 6)
        Else
        HexaColor = "&" & Application.Dec2Hex(Target.Font.Color, 6)
    End If
   
End Function

Supposons que la cellule soit d'un abominable violet, le code sera :
HexaColor([B5]) = &DE2064
Ce code n'est apparemment pas compris pour "BackColor" du "Label". Il faut le transformer pour qu'il soit intelligible en : &HDE2064&
Pour y parvenir, je tente ceci :
- 1/ je transforme &DE2064 en &DE2064&
- 2/ j'intercale un "H" après le 1er "&"

Function InsertionCaractère(MaChaine As String, Insert As String, i As Byte) As String
'Insertion d'un caractère dans une chaîne
'- MaChaine = la chaîne dans laquelle on veut insérer le caractère
'- Insert = le caractère à insérer
'- i = la position dans la chaîne, en partant de la gauche, du caractère que l'on veut insérer

    MaChaine = Left$(MaChaine, i - 1) & Insert & Mid$(MaChaine, i)
    InsertionCaractère = MaChaine

End Function

Je vérifie si le "néo-code" est bien retranscrit en faisant un test :
[P30] = InsertionCaractère(HexaColor([B5]) & "&", "H", 2)
La cellule "P30" affiche bien le code normalement compris dans les propriétés du label en question, soit &HDE2064&.
Je suis content !
Maintenant, audacieusement, je tente :

    With Worksheets("BTX").LabelmLparGr1
        .BackColor = InsertionCaractère(HexaColor([B5]) & "&", "H", 2)
    End With

Ça ne marche pas. Je ne suis pas content !

Comment faire en sorte pour que je redevienne content ?

 

[Staple1600]

Bonsoir à tous

Docteur Magique
Pourquoi ne pas utiliser qu'une seule fonction (ainsi modifiée) ?

Sub a()
Feuil1.Label1.BackColor = HexaColor(Range("A1"))
End Sub
Function HexaColor(Target As Range, Optional fond As Integer) As String
'Renvoie le code hexadécimal d'une couleur
'Lone-wolf
'---- 0 ou absence du 2eme argument renvoie la couleur de remplissage
'---- tout autre nombre renvoie la couleur de la police
'---- renvoi la couleur par défaut hors Mise En Forme Conditionnelle

    Application.Volatile
    If fond = 0 Then
        HexaColor = "&H" & Application.Dec2Hex(Target.Interior.Color, 6)
        Else
        HexaColor = "&H" & Application.Dec2Hex(Target.Font.Color, 6)
    End If
End Function

 

[mapomme]

Bonsoir Magic_Color , Staple1600 ,

Et pourquoi pas sans fonction de conversion ? :

Sub Fond_Police()
  With Worksheets("BTX").LabelmLparGr1
    If [b5].Interior.ColorIndex = xlColorIndexNone Then
      .BackStyle = fmBackStyleTransparent
    Else
      .BackStyle = fmBackStyleOpaque
      .BackColor = [b5].Interior.Color
    End If
    .ForeColor = [b5].Font.Color
  End With
End Sub

nota: @ Magic_Doctor , vous êtes sur une mauvaise pente ! Vos fichiers joints deviennent rarissimes. Est-ce désormais à chaque répondeur d'en créer un pour ses tests ?

 

[Staple1600]

Bonsoir mapomme

Tout ce qui guidait mes pas c'était cette supplique

Comment faire en sorte pour que je redevienne content ?

Je visais le contentement béat du Docteur Magique et non point l'élégance du code VBA
(qui d'ailleurs au départ n'est pas le mien )

 

[Magic_Doctor]

Bonsoir,

Merci pour vos réponses.
Ça y est, je suis non seulement content mais aussi dans un état de béatitude sereine qui laisse coi mon entourage.
J'aurais dû en effet mettre une PJ, mon post #1 aurait été en plus nettement plus court.
Pourquoi faire compliqué quand on peut faire simple ? J'ai donc choisi la proposition de mapomme que j'ai en plus minimalisée. Ça marche très bien !
Un détail, sans grande importance (puisque ça marche). Comme il y a en fait 2 labels qui subissent simultanément la même modification, comment les sélectionner ensemble afin de les modifier en un tournemain plutôt que de les traiter l'un après l'autre ? Supposons qu'il y ait 36 labels...
J'ai bien tenté comme ceci :

        With ActiveSheet.Shapes.Range(Array("LabelmLparGr1", "LabelmLparGr2"))
                .BackColor = [A1].Interior.Color
                .ForeColor = IIf(Int([A1].Interior.Color / 256) Mod 256 > 128, vbBlack, vbWhite) 'adapte la couleur de la police à celle de la cellule
        End With

mais sans succès...

 

[mapomme]

Bonjour Magic_Doctor ,

Essayez:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim label
  If Target.Address = [A1].Address Then
    Cancel = True
    For Each label In Me.OLEObjects(Array("LabelmLparGr1", "LabelmLparGr2"))
      label.Object.BackColor = [A1].Interior.Color
      label.Object.ForeColor = IIf(Int([A1].Interior.Color / 256) Mod 256 > 128, vbBlack, vbWhite)
    Next label
  End If
End Sub

 

[Staple1600]

Bonjour à tous, Docteur Magique, mapomme

Pour traiter tous les labels de la feuille active

Sub a()
Dim Obj As OLEObject
For Each Obj In ActiveSheet.OLEObjects
If TypeOf Obj.Object Is MSForms.label Then Obj.Object.BackColor = [A1].Interior.Color
Next
End Sub

 

[Magic_Doctor]

Bonsoir,

Il fallait donc passer par une boucle.
La solution de mapomme résoud parfaitement le problème car il n'y a que 2 labels concernés dans l'ensemble des labels de la feuille.