.
Estando dicutiendo con Psyke1 sobre un metodo de reconocimiento de colores y casi 2 semanas indagando en ello he creado esta clase que verifica si un color es similar a otro (Despresiando el componente Alpha).
Aqui les dejo e modulo de clase:
* La funcion que tiene es que reconoce TONOS de un color y retorna true si es derivado del mismo color ya sea un color mas claro u opaco.
cSpectrumColor.cls
'
' /////////////////////////////////////////////////////////////
' // //
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo //
' /////////////////////////////////////////////////////////////
' // http://infrangelux.hostei.com/index.php?option=com_content&view=article&id=35:cspectrumcolor&catid=15:catmoduloscls&Itemid=24
' /////////////////////////////////////////////////////////////
Option Explicit
Private lRGBA As Long
Public Property Get color() As Long
color = lRGBA
End Property
Public Property Let color(ByVal lColor As Long)
lRGBA = lColor
End Property
Public Function spectrumEqualL(ByVal lColorRGBA As Long, Optional ByVal lTolerance As Long = 10) As Boolean
Dim oSpectrum As cSpectrumColor
Set oSpectrum = New cSpectrumColor
oSpectrum.color = lColorRGBA
spectrumEqualL = spectrumEqualC(oSpectrum)
Set oSpectrum = Nothing
End Function
Public Function spectrumEqualC(ByVal oSpectrum As cSpectrumColor, Optional ByVal lTolerance As Long = 10) As Boolean
Dim lRed(1) As Long
Dim lGreen(1) As Long
Dim lBlue(1) As Long
Dim lBackColor As Long
lBackColor = oSpectrum.spectrumScale(oSpectrum.scaleFactorL(lRGBA) - 100)
Call oSpectrum.componentsRGBA(lRed(1), lGreen(1), lBlue(1), &H0)
oSpectrum.color = lBackColor
Call componentsRGBA(lRed(0), lGreen(0), lBlue(0), &H0)
If (max(lRed(0), lRed(1)) - min(lRed(0), lRed(1)) < lTolerance) Then
If (max(lGreen(0), lGreen(1)) - min(lGreen(0), lGreen(1)) < lTolerance) Then
If (max(lBlue(0), lBlue(1)) - min(lBlue(0), lBlue(1)) < lTolerance) Then
spectrumEqualC = True
End If
End If
End If
End Function
Public Function spectrumScale(ByVal lScale As Double) As Long
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
'Dim lAlpha As Long
spectrumScale = lRGBA
Call componentsRGBA(lRed, lGreen, lBlue, &H0)
Call Me.colorFromRGBA(((lRed * (lScale / 100)) + lRed), ((lGreen * (lScale / 100)) + lGreen), ((lBlue * (lScale / 100)) + lBlue), &H0)
End Function
Public Function scaleFactorL(ByVal lColorRGBA As Long) As Double
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
'Dim lAlpha As Long
Call componentsRGBA(lRed, lGreen, lBlue, &H0)
Select Case max3(lRed, lGreen, lBlue)
Case lRed: If (lRed) Then scaleFactorL = (lColorRGBA And &HFF&) * 100 / lRed
Case lGreen: If (lGreen) Then scaleFactorL = ((lColorRGBA And &HFF00&) \ &H100&) * 100 / lGreen
Case lBlue: If (lBlue) Then scaleFactorL = ((lColorRGBA And &HFF0000) \ &H10000) * 100 / lBlue
End Select
End Function
Public Function scaleFactorC(ByVal oSpectrum As cSpectrumColor) As Double
scaleFactorC = scaleFactorL(oSpectrum.color())
End Function
Private Function max(ByVal lVal1 As Long, ByVal lval2 As Long) As Long
If (lVal1 > lval2) Then
max = lVal1
Else
max = lval2
End If
End Function
Private Function min(ByVal lVal1 As Long, ByVal lval2 As Long) As Long
If (lVal1 < lval2) Then
min = lVal1
Else
min = lval2
End If
End Function
Private Function max3(ByVal lVal1 As Long, ByVal lval2 As Long, ByVal lval3 As Long) As Long
max3 = max(max(lVal1, lval2), lval3)
End Function
Public Sub componentsRGBA(ByRef lRed As Long, ByRef lGreen As Long, ByRef lBlue As Long, ByRef lAlpha As Long)
lRed = (lRGBA And &HFF&)
lGreen = ((lRGBA And &HFF00&) / &H100&)
lBlue = ((lRGBA And &HFF0000) / &H10000)
lAlpha = ((lRGBA And &HFF000000) / &H1000000)
End Sub
Public Sub colorFromRGBA(ByVal lRed As Long, ByVal lGreen As Long, ByVal lBlue As Long, ByVal lAlpha As Long)
lRGBA = (lRed)
lRGBA = (lRGBA Or ((lGreen And &HFF&) * &H100&))
lRGBA = (lRGBA Or ((lBlue And &HFF&) * &H10000))
lRGBA = (lRGBA Or ((lAlpha And &HFF&) * &H1000000))
End Sub
Prueba/Test:
' // En un form...
' // Se requieren 6 VScroll (con propiedad Index).
' // Se requieren 2 PictureBox (con propiedad Index)
Option Explicit
Dim oSpectrum(1) As cSpectrumColor
Private Sub Form_Load()
Dim i As Long
Set oSpectrum(0) = New cSpectrumColor
Set oSpectrum(1) = New cSpectrumColor
For i = VScroll1.LBound To VScroll1.UBound
VScroll1(i).min = 0
VScroll1(i).max = 255
Next
End Sub
Private Sub Form_Terminate()
Set oSpectrum(0) = Nothing
Set oSpectrum(1) = Nothing
End Sub
Private Sub VScroll1_Change(Index As Integer)
Call VScroll1_Scroll(Index)
End Sub
Private Sub VScroll1_Scroll(Index As Integer)
Dim i As Long
If (Index > &H2) Then i = 1
Picture1(i).BackColor = RGB(Int(VScroll1((i * 3)).Value), _
Int(VScroll1((i * 3) + 1).Value), _
Int(VScroll1((i * 3) + 2).Value))
oSpectrum(i).color = Picture1(i).BackColor
Debug.Print oSpectrum(i).spectrumEqualC(oSpectrum(i Xor 1)), i, i Xor 1
End Sub
P.D.: el codigo lo estare editando y publicando en cSpectrumColor (http://infrangelux.hostei.com/index.php?option=com_content&view=article&id=35:cspectrumcolor&catid=15:catmoduloscls&Itemid=24).
Temibles Lunas!¡.
.
* Nota se que puedo ocupar en lugar de long el tipo byte en los componentes RGBA pero lo he dejado en long por cuestiones personales...
Dulces Lunas!¡.
Dejo esta reduccion que no usa clases solo se invoca la funcion equalSpectrumColor.
'
' /////////////////////////////////////////////////////////////
' // //
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este Codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandesido //
' // o achicado, si es en base a este codigo //
' /////////////////////////////////////////////////////////////
Option Explicit
Private Function max(ByVal lVal1 As Long, ByVal lVal2 As Long) As Long
If (lVal1 > lVal2) Then
max = lVal1
Else
max = lVal2
End If
End Function
Private Function max3(ByVal lVal1 As Long, ByVal lVal2 As Long, ByVal lval3 As Long) As Long
max3 = max(max(lVal1, lVal2), lval3)
End Function
Private Function min(ByVal lVal1 As Long, ByVal lVal2 As Long) As Long
If (lVal1 < lVal2) Then
min = lVal1
Else
min = lVal2
End If
End Function
Private Function min3(ByVal lVal1 As Long, ByVal lVal2 As Long, ByVal lval3 As Long) As Long
min3 = min(min(lVal1, lVal2), lval3)
End Function
Public Sub longToRGBA(ByVal lRGBA As Long, ByRef bRed As Byte, ByRef bGreen As Byte, ByRef bBlue As Byte, ByRef bAlpha As Byte)
bRed = (lRGBA And &HFF&)
bGreen = ((lRGBA And &HFF00&) / &H100&)
bBlue = ((lRGBA And &HFF0000) / &H10000)
bAlpha = ((lRGBA And &HFF000000) / &H1000000)
End Sub
Public Function RGBAToLong(ByVal bRed As Long, ByVal bGreen As Long, ByVal bBlue As Long, ByVal bAlpha As Long) As Long
RGBAToLong = (bRed) Or ((bGreen And &HFF&) * &H100&) Or ((bBlue And &HFF&) * &H10000) Or ((bAlpha And &HFF&) * &H1000000)
End Function
Public Function scaleSpectrumFactor(ByVal lColor1 As Long, ByVal lColor2 As Long) As Double
Dim bRed As Byte
Dim bGreen As Byte
Dim bBlue As Byte
'Dim bAlpha As byte
Call longToRGBA(lColor1, bRed, bGreen, bBlue, &H0)
Select Case max3(bRed, bGreen, bBlue)
Case bRed: If (bRed) Then scaleSpectrumFactor = (lColor2 And &HFF&) * 100 / bRed
Case bGreen: If (bGreen) Then scaleSpectrumFactor = ((lColor2 And &HFF00&) \ &H100&) * 100 / bGreen
Case bBlue: If (bBlue) Then scaleSpectrumFactor = ((lColor2 And &HFF0000) \ &H10000) * 100 / bBlue
End Select
End Function
Public Function spectrumColorScale(ByVal lColor As Long, ByVal lScale As Double) As Long
Dim bRed As Byte
Dim bGreen As Byte
Dim bBlue As Byte
'Dim bAlpha As byte
Call longToRGBA(lColor, bRed, bGreen, bBlue, &H0)
spectrumColorScale = RGBAToLong(((bRed * (lScale / 100)) + bRed), ((bGreen * (lScale / 100)) + bGreen), ((bBlue * (lScale / 100)) + bBlue), &H0)
End Function
Public Sub lSwap(ByRef lVal1 As Long, ByRef lVal2 As Long)
' // Intercambia {lVal1} por {lVal2} y {lVal2} a {lVal1} sin variable temporal
lVal1 = lVal1 Xor lVal2
lVal2 = lVal2 Xor lVal1
lVal1 = lVal1 Xor lVal2
End Sub
Public Function equalSpectrumColor(ByVal lColor1 As Long, ByVal lColor2 As Long, Optional ByVal lTolerance As Long = 10) As Boolean
Dim bRed(1) As Byte
Dim bGreen(1) As Byte
Dim bBlue(1) As Byte
'Dim bAlpha(1) As byte
If (lColor1 > lColor2) Then Call lSwap(lColor1, lColor2)
Call longToRGBA(spectrumColorScale(lColor2, scaleSpectrumFactor(lColor2, lColor1) - 100), bRed(1), bGreen(1), bBlue(1), &H0)
Call longToRGBA(lColor1, bRed(0), bGreen(0), bBlue(0), &H0)
If (max(bRed(0), bRed(1)) - min(bRed(0), bRed(1)) < lTolerance) Then
If (max(bGreen(0), bGreen(1)) - min(bGreen(0), bGreen(1)) < lTolerance) Then
If (max(bBlue(0), bBlue(1)) - min(bBlue(0), bBlue(1)) < lTolerance) Then
equalSpectrumColor = True
End If
End If
End If
End Function
Temibles Lunas!¡.