[Source] SpectrumColor ( Reconocimiento de tonos de colores ).

[BlackZeroX]

.
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

Código (vb) [Seleccionar] Expandir



'
'   /////////////////////////////////////////////////////////////
'   //                                                         //
'   // 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:

Código (vb) [Seleccionar] Expandir




'   //  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.

Temibles Lunas!¡.

[BlackZeroX]

.
* 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!¡.

[BlackZeroX]

Dejo esta reduccion que no usa clases solo se invoca la funcion  equalSpectrumColor.

Código (vb) [Seleccionar] Expandir



'
'   /////////////////////////////////////////////////////////////
'   //                                                         //
'   // 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!¡.