Título: [Source] SpectrumColor ( Reconocimiento de tonos de colores ).
Publicado por: BlackZeroX en 8 Octubre 2011, 21:55 pm
. 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!ˇ.
Título: Re: [Source] cSpectrumColor
Publicado por: BlackZeroX en 8 Octubre 2011, 22:12 pm
. * 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!ˇ.
Título: Re: [Source] cSpectrumColor
Publicado por: BlackZeroX en 8 Octubre 2011, 22:46 pm
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!ˇ.
|