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 :
VB:
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 "&"
VB:
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 :
VB:
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 ?
Docteur Magique
Pourquoi ne pas utiliser qu'une seule fonction (ainsi modifiée) ?
VB:
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
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 ?
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 :
VB:
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
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
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
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.