Notifications
Clear all

macro para clarear escurecer cor

7 Posts
3 Usuários
0 Reactions
1,270 Visualizações
(@edcronos)
Posts: 1006
Noble Member
Topic starter
 

sei que é algo dificil, no começo até tentei baixei um monte de coisa, e nem lembro se abri algum topico a respeito

estou precisando de uma macro que clareie e escureça a cor escolhida, algo simples "até parece :roll: "
mas se alguem conhecer alguma com essa funcionalidade

até mais...

Somente é impossíveis até que alguém faça
A logica está presa na irracionalidade humana, e morta nos que se consideram donos da verdade.

"ALGUM MODERADOR ME EXPULSE DO FÓRUM POR FAVOR"

 
Postado : 30/03/2015 8:50 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Não sei se entendi, mas pode-se "manipular" as cores atraves da combinação RGB
Seria algo +/- assim:

Sub Mexecores1()
With Range("N5:P9").Interior
'With Selection.Interior
    .Color = RGB(204, 217, 255)
espera
    .Color = RGB(173, 198, 255)
espera
    .Color = RGB(153, 179, 255)
espera
    .Color = RGB(128, 159, 255)
espera
    .Color = RGB(102, 140, 255)
espera
    .Color = RGB(77, 121, 255)
End With
End Sub

Sub espera()
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 1
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime
End Sub

Aqui mais sobre esquema de cores:
http://inanyplace.blogspot.com.br/2012/ ... olors.html
http://www.colorschemer.com/online.html

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 30/03/2015 10:57 am
Issamu
(@issamu)
Posts: 605
Honorable Member
 

Use os códigos associando cada um a algum botão de atalho, que você vai conseguir clarear ou escurecer facilmente um intervalo selecionado:

Sub clarear()

Dim rng As Excel.Range

For Each rng In Intersect(Selection, Selection.Parent.UsedRange)
On Error Resume Next
rng.Interior.TintAndShade = rng.Interior.TintAndShade + 0.05
Next rng

End Sub

Sub Escurecer()

Dim rng As Excel.Range

For Each rng In Intersect(Selection, Selection.Parent.UsedRange)
On Error Resume Next
rng.Interior.TintAndShade = rng.Interior.TintAndShade - 0.05
Next rng

End Sub

Rafael Issamu F. Kamimura
Moderador Oficial Microsoft Community - MCC (Contribuidor do Microsoft Community)
http://zip.net/bjrt0X - http://zip.net/bhrvbR
Foi útil? Clique na mãozinha
Conheça: http://excelmaniacos.com/

 
Postado : 30/03/2015 12:05 pm
(@edcronos)
Posts: 1006
Noble Member
Topic starter
 

ola ronaldo e issamu

agradeço pela atenção
issamu ,
matematica comum não funciona muito bem, as cores para ter uma tonalização correta tem que ser convertida para hsb se me lembro bem
é bem complicado o processo tem escala logaritima de cada valor, tinha tentado até com variações rgb, mas as cores fugiam
se bem que não tentei no padrão TintAndShade "vou dar uma verificada"
para ter uma ideia:
oq já tentei, mas na epoca não estava tão preparado

Type HSL
    Hue As Long
    Saturation As Long
    Luminance As Long
End Type

Public Function RGBToHSL01(ByVal RGBValue As Long) As HSL

    Dim lMin As Long, lMax As Long, lDelta As Long
    Dim R As Long, G As Long, B As Long
    Dim nTemp As Single

    R = RGBValue And &HFF
    G = (RGBValue And &HFF00&)  &H100&
    B = (RGBValue And &HFF0000)  &H10000

    lMax = IIf(R > G, IIf(R > B, R, B), IIf(G > B, G, B))
    lMin = IIf(R < G, IIf(R < B, R, B), IIf(G < B, G, B))

    RGBToHSL01.Luminance = (lMax * 100) / 255

    If lMax > 0 Then
        lDelta = lMax - lMin
        RGBToHSL01.Saturation = (lDelta / lMax) * 100
        If lDelta > 0 Then
            If lMax = R Then
                nTemp = (G - B) / lDelta
            ElseIf lMax = G Then
                nTemp = 2 + (B - R) / lDelta
            Else
                nTemp = 4 + (R - G) / lDelta
            End If
            RGBToHSL01.Hue = nTemp * 60
            If RGBToHSL01.Hue < 0 Then
                RGBToHSL01.Hue = RGBToHSL01.Hue + 360
            End If
        End If
    End If

End Function


Public Function RGBToHSL03(ByVal RGBValue As Long) As HSL

  Dim R As Long, G As Long, B As Long
  Dim lMax As Long, lMin As Long
  Dim q As Single
  Dim lDifference As Long
  Static Lum(255) As Long
  Static QTab(255) As Single
  Static init As Long
  
  If init = 0 Then
    For init = 2 To 255 ' 0 and 1 are both 0
      Lum(init) = init * 100 / 255
    Next
    For init = 1 To 255
      QTab(init) = 60 / init
    Next init
  End If

  R = RGBValue And &HFF
  G = (RGBValue And &HFF00&)  &H100&
  B = (RGBValue And &HFF0000)  &H10000

  If R > G Then
    lMax = R: lMin = G
  Else
    lMax = G: lMin = R
  End If
  If B > lMax Then
    lMax = B
  ElseIf B < lMin Then
    lMin = B
  End If

  RGBToHSL03.Luminance = Lum(lMax)
  
  lDifference = lMax - lMin
  If lDifference Then
    ' do a 65K 2D lookup table here for more speed if needed
    RGBToHSL03.Saturation = (lDifference) * 100 / lMax
    q = QTab(lDifference)
    Select Case lMax
    Case R
      If B > G Then
        RGBToHSL03.Hue = q * (G - B) + 360
      Else
        RGBToHSL03.Hue = q * (G - B)
      End If
    Case G
      RGBToHSL03.Hue = q * (B - R) + 120
    Case B
      RGBToHSL03.Hue = q * (R - G) + 240
    End Select
  End If
End Function

Function RGB(CellRef As Variant)    'retorna a cor do endereço da celula em Hexa
    RGB = ToHex(Range(CellRef).Interior.Color)
End Function

Function ToHex(ByVal N As Long) As String    'transforma padrão COLOR em HEXA
    strH = ""
    For i = 1 To 6
        d = N Mod 16
        strH = Chr(48 + (d Mod 9) + 16 * (d  9)) & strH
        N = N  16
    Next
    ToHex = strH
End Function

Function rgb_color(cl As Range) As String 'retorna a cor da celula em RGB

        R = cl.Interior.Color Mod 256
        rgbc = Int(cl.Interior.Color / 256)
        G = rgbc Mod 256
        B = Int(rgbc / 256)
        
        rgb_color = "Red - " & R & " Green - " & G & " Blue - " & B

End Function

Sub ChangeColorRangeColors()
    Dim R As Long, G As Long, B As Long
    Dim H As Long, S  As Long, L As Long
    clr = Selection.Interior.Color     ' get clr
SplitRGB1 clr, R, G, B ' split RGB

    If R < 240 Or G < 240 Or B < 240 Then    'skip whites – when all RGB componenst are above 240

       RGBToHSL01 clr, H, S, L
        L = (iLuminosity / 255)    'from 0.0 to 1.0      'increase luminosity
        S = (iSaturation / 255)    'from 0.0 to 1.0   'decrease saturation
        HSLtoRGB H, S, L, clr    'get RGB

    End If

End Sub

Sub SplitRGB1(ByVal RGBValue As Long, _
        ByRef R As Long, _
        ByRef G As Long, _
        ByRef B As Long)
    Dim HexString As String

    ' convert the long to Hex – bb:gg:rr
    HexString = Hex(RGB)
    ' in order to get r,g,b components out of the string,
    ' we have to make it is atleast 6 characters long – bb:gg:rr
    HexString = Right(String$(5, "0") & HexString, 6)
    ' get each individual color and convert to an double (range: 0 to 255)
    R = CDbl("&H" & Mid$(HexString, 5, 2))
    G = CDbl("&H" & Mid$(HexString, 3, 2))
    B = CDbl("&H" & Mid$(HexString, 1, 2))
End Sub

reinaldo ,
sinceramente não entendi a macro, vou dar uma estudada nela

mas para esplicar melhor:
minha planilha está separada em setores,
como esses setores são dinamicos e independentes mas podem interagir entre eles
cada setor um tem uma cor diferente um do outro
dentro do setor tem tonalidades de cor diferente os dados

no momento estou com um numero limitado de setores "10" então uso uma tabela

mas vou ampliar a capacidade da planilha e colocar a criação de setores tbm dinâmico,
podendo escolher uma cor
e a macro tem que tonalizar essa cor para cada coluna do setor de acordo com os tipos de dados

vou tentar estudar as soluções apresentadas, senão vai na base de tabela de cores fixas mesmo

Somente é impossíveis até que alguém faça
A logica está presa na irracionalidade humana, e morta nos que se consideram donos da verdade.

"ALGUM MODERADOR ME EXPULSE DO FÓRUM POR FAVOR"

 
Postado : 30/03/2015 6:02 pm
(@edcronos)
Posts: 1006
Noble Member
Topic starter
 

certo reinaldo entendi a macro
ela troca entre as cores "pré" estabelecidas em intervalo de tempo

eu não quero ter que usar sar cores fixa
e quero poder colocar brilho livremente para dar maior ou menor realce sem parecer colcha de retalho

Somente é impossíveis até que alguém faça
A logica está presa na irracionalidade humana, e morta nos que se consideram donos da verdade.

"ALGUM MODERADOR ME EXPULSE DO FÓRUM POR FAVOR"

 
Postado : 30/03/2015 6:15 pm
Issamu
(@issamu)
Posts: 605
Honorable Member
 

Olá Edcronos!
Uso o código que passei sem nenhum tipo de problema e tem se mostrado bem útil para realizar o design das planilhas. Eu deixei o código na minha pasta Pessoal de macros e até deixei associada a uma guia personalizada. Veja a imagem de um exemplo, onde cada linha representa um clique no Clarear.

Rafael Issamu F. Kamimura
Moderador Oficial Microsoft Community - MCC (Contribuidor do Microsoft Community)
http://zip.net/bjrt0X - http://zip.net/bhrvbR
Foi útil? Clique na mãozinha
Conheça: http://excelmaniacos.com/

 
Postado : 31/03/2015 5:47 am
(@edcronos)
Posts: 1006
Noble Member
Topic starter
 

na epoca tentei de tudo
menos TintAndShade, teve outros padrões tbm

mas dependendo da cor não funciona muito bem o processo
principalmente as cores pasteis
isso pq as cores padrões vermelho, verde, azul, tem um ajuste igual
e para a tonalização correta da cor cada cor tem uma variação diferente logaritima

se eu não me engano eu tinha feito uma macro que chegava perto sem muita complicação, mas mesmo assim fugia em alguns pontos

Somente é impossíveis até que alguém faça
A logica está presa na irracionalidade humana, e morta nos que se consideram donos da verdade.

"ALGUM MODERADOR ME EXPULSE DO FÓRUM POR FAVOR"

 
Postado : 31/03/2015 8:43 am