exercice: drapeau arc en ciel automatique, problème variable couleur

tweedi · 5 Décembre 2012

Bonsoir à tous,

Ce soir j'essaie de réaliser le drapeau avec les couleurs de l'arc en ciel. C'est à dire que la macro doit colorer les cellules les unes en dessous des autres avec des couleurs prédéfinies.

Pour moi la difficulté vient du fait que les codes couleurs ne se suivent pas (1 = noir, 2 = blanc, 3 = rouge ce n'es pas dur).

J'ai réussi à le faire mais je trouve le code très lourd:

Sub rainbow()
With Sheets("feuil1")
With .Cells(1, 1).Interior
.ColorIndex = 7
End With
With .Cells(2, 1).Interior
.ColorIndex = 3
End With
With .Cells(3, 1).Interior
.ColorIndex = 46
End With
With .Cells(4, 1).Interior
.ColorIndex = 6
End With
With .Cells(5, 1).Interior
.ColorIndex = 10
End With
With .Cells(6, 1).Interior
.ColorIndex = 8
End With
With .Cells(7, 1).Interior
.ColorIndex = 5
End With
With .Cells(8, 1).Interior
.ColorIndex = 21
End With
End With
End Sub

Je ne pense pas avoir de problème pour la variable des lignes, un "FOR NEXT" devrait faire l'affaire, mais pour les couleurs comment faire pour automatiser ? il faut que la boucle passe d'une valeur à l'autre et dans un ordre précis.

Merci pour votre aide et très bonne soirée à tous

tweedi

Dranreb · 6 Décembre 2012

Re : exercice: drapeau arc en ciel automatique, problème variable couleur

Bonsoir.
Comme ça par exemple:

VB:

Sub Rainbow()
Dim L As Long
For L = 1 To 8
   Feuil1.Cells(L, 1).Interior.ColorIndex = Array(7, 3, 46, 6, 10, 8, 5, 21)(L - 1)
   Next L
End Sub

À +

tweedi · 6 Décembre 2012

Re : exercice: drapeau arc en ciel automatique, problème variable couleur

Ca marche merci

tweedi · 6 Décembre 2012

Re : exercice: drapeau arc en ciel automatique, problème variable couleur

Rebonjour

Je reviens vers vous pour savoir pourquoi iol faut mettre (i-1) après le array ?
Je ne comprend pas, je remarque qu'avec un simple i les couleurs sont décalées et il en manque une, mais je ne vois pas pourquoi ?

Merci

Edit: je pense enfin avoir trouvé, array commence à 0 n'est-ce pas ?

Dranreb · 6 Décembre 2012

Re : exercice: drapeau arc en ciel automatique, problème variable couleur

Bonjour.
Oui c'est cela: la fonction Array définit toujours des tableaux d'indice de départ 0. Donc quand I=1 l'indice est I-1 et toujours aussi ensuite.
Cordialement.

Modeste geedee · 6 Décembre 2012

Re : exercice: drapeau arc en ciel automatique, problème variable couleur

Bonsour®

tweedi à dit:
Bonsoir à tous,
Ce soir j'essaie de réaliser le drapeau avec les couleurs de l'arc en ciel. C'est à dire que la macro doit colorer les cellules les unes en dessous des autres avec des couleurs prédéfinies.
Pour moi la difficulté vient du fait que les codes couleurs ne se suivent pas (1 = noir, 2 = blanc, 3 = rouge ce n'es pas dur).
tweedi

l'utilisation des colors index est limité à 56 valeurs distinctes.
A partir de Excel 2007 il y a accés à plus de couleurs, mais la gestion passe par l'utilisation des thémes.
il est cependant possible a l'aide de la fonction RGB d'obtenir l'un quelconque des 16 millions et des *** de couleurs "distinctes"

un exemple d'utilisation :Arc-en-ciel + 8 niveau de gris

VB:

Sub PaletteArcEnCiel()
Dim i As Integer, j As Integer, idx As Integer, k As Integer, R As Integer, G As Integer, B As Integer
    ReDim TblR(56)
    ReDim TblG(56)
    ReDim TblB(56)
    ReDim Tblrgb(56)
    ThisWorkbook.Sheets.Add
    Application.ScreenUpdating = False
    [A1] = "Idx": [B1] = "Defaut": [c1] = "Dec": [D1] = "R": [E1] = "G": [F1] = "B": [G1] = "Hex": [H1] = "Arc-en-ciel": [I1] = "Dec": [J1] = "R": [K1] = "G": [L1] = "B": [M1] = "Hex"
    For i = 1 To 7
        For j = 1 To 8
            idx = j + (8 * (i - 1)) ' calcul index de la palette
            k = (j - 1) * 32
            Select Case i
            Case 2
                TblR(idx) = 255:     TblG(idx) = k:       TblB(idx) = 0
            Case 3
                TblR(idx) = 255 - k: TblG(idx) = 255:     TblB(idx) = 0
            Case 4
                TblR(idx) = 0:       TblG(idx) = 255:     TblB(idx) = k
            Case 5
                TblR(idx) = 0:       TblG(idx) = 255 - k: TblB(idx) = 255
            Case 6
                TblR(idx) = k:       TblG(idx) = 0:       TblB(idx) = 255
            Case 1
                TblR(idx) = 255:     TblG(idx) = 0:       TblB(idx) = 255 - k
            Case Else '---- de noir 0,0,0  àblanc 255,255,255)
                TblR(idx) = Round(((j - 1) * 36.425), 0):    TblG(idx) = TblR(idx):    TblB(idx) = TblR(idx)
            End Select
          
            Tblrgb(idx) = RGB(TblR(idx), TblG(idx), TblB(idx))
         
            With ActiveSheet
            .Cells(1 + idx, 1).Value = idx
            .Cells(1 + idx, 2).Interior.ColorIndex = idx
            R = ThisWorkbook.Colors(idx) Mod 256
            G = Int(ThisWorkbook.Colors(idx) / 256 ^ 1) Mod 256
            B = Int(ThisWorkbook.Colors(idx) / 256 ^ 2) Mod 256
             .Cells(1 + idx, 3).Value = ThisWorkbook.Colors(idx)
             .Cells(1 + idx, 4).Value = R
              .Cells(1 + idx, 5).Value = G
               .Cells(1 + idx, 6).Value = B
               .Cells(1 + idx, 7).Value = "&H" & Application.Dec2Hex(B, 2) & Application.Dec2Hex(G, 2) & Application.Dec2Hex(R, 2)
              
            .Cells(1 + idx, 8).Interior.Color = Tblrgb(idx)
              .Cells(1 + idx, 9).Value = Tblrgb(idx)
              .Cells(1 + idx, 10).Value = TblR(idx)
            .Cells(1 + idx, 11).Value = TblG(idx)
            .Cells(1 + idx, 12).Value = TblB(idx)
            .Cells(1 + idx, 13).Value = "&H" & Application.Dec2Hex(TblB(idx), 2) & Application.Dec2Hex(TblG(idx), 2) & Application.Dec2Hex(TblR(idx), 2)
    End With
             '********************************************
            ' affectation RGB à la palette
            ' ThisWorkbook.Colors(idx) = tblrgb(idx)
            '********************************************
        Next
    Next
            '********************************************
            ' restoration palette par defaut
            ' ThisWorkbook.ResetColors
            '********************************************
     Application.ScreenUpdating = True
  End Sub

exercice: drapeau arc en ciel automatique, problème variable couleur

tweedi

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

tweedi

XLDnaute Nouveau

tweedi

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

Modeste geedee

XLDnaute Barbatruc

Discussions similaires