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