[RETO] GetMaskColor

[LeandroA]

Hola esta es una función que debo realizar así que la pongo como un reto para quienes estén aburridos, les cuento de que se trata, la idea es obtener el color de mascara de una imagen, como pueden ver en la siguiente

a simple vista reconocemos que es un color Magenta, lo que intentaremos es obtenerlo mediante código, para no complicar las cosas usaremos un PictureBox sin bordes (BordeStyle = none), AutoSize = True  y ScaleMode = vbPixels
para obtener el color utilizaremos el api GetPixel

Código [Seleccionar] Expandir

Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

entonces en el picture pondremos una de las imagenes que se encuentran abajo de todo.
la imagen es una tira de iconos, nosotros debemos verificar en cada esquina de ese icono cual es el color, el color que se repita mas veces sera el color de mascara
como muestro en esta imagen
con puntos azules y rojos son los puntos donde debemos comprobar el color almacenarlo en algún array o lo que sea y luego ir sumando para al final ver cual es el que se repitio mas veces.












como son todos iconos cuadrados una ayuda para obtener el tamaño de cada icono y la cantidad de iconos

Código [Seleccionar] Expandir

Private Sub Form_Load()
    Dim lWidth As Long
    Dim lHeight As Long
    Dim NumIcon As Long

    lWidth = (Picture1.ScaleWidth \ Picture1.ScaleHeight)
    If lWidth = 0 Then lWidth = 1
    lWidth = Picture1.ScaleWidth \ lWidth
    lHeight = Picture1.ScaleHeight
   
    NumIcon = Picture1.ScaleWidth \ lWidth
   
    Debug.Print lWidth, lHeight, NumIcon
End Sub

[seba123neo]

Hola, esta hecho asi nomas, debe tener algun error, pero es la idea no ?

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
   
Private vArrColores() As Variant

Private Sub Form_Load()
    Dim lWidth As Long
    Dim lHeight As Long
    Dim NumIcon As Long
   
    lWidth = (Picture1.ScaleWidth \ Picture1.ScaleHeight)
    If lWidth = 0 Then lWidth = 1
    lWidth = Picture1.ScaleWidth \ lWidth
    lHeight = Picture1.ScaleHeight
   
    NumIcon = Picture1.ScaleWidth \ lWidth
   
    lWidth = lWidth / 15
    lHeight = lHeight / 15
   
    Dim i As Integer
    Dim vCont As Integer
   
    vCont = 0
   
    ReDim vArrColores(NumIcon * 4)

    For i = 0 To NumIcon - 1
   
        'Verifica la esquina Izquiera superior
        If i > 0 Then
            Debug.Print Picture1.hdc, (lWidth * i) + 1, 0
            vArrColores(vCont) = GetPixel(Picture1.hdc, (lWidth * i) + 1, 0)
        Else
            Debug.Print Picture1.hdc, lWidth * i, 0
            vArrColores(vCont) = GetPixel(Picture1.hdc, lWidth * i, 0)
        End If
       
        vCont = vCont + 1
       
        'Verifica la esquina Izquiera inferior
        If i > 0 Then
            Debug.Print Picture1.hdc, (lWidth * i) + 1, lHeight - 1
            vArrColores(vCont) = GetPixel(Picture1.hdc, (lWidth * i) + 1, lHeight - 1)
        Else
            Debug.Print Picture1.hdc, lWidth * i, lHeight - 1
            vArrColores(vCont) = GetPixel(Picture1.hdc, lWidth * i, lHeight - 1)
        End If
       
        vCont = vCont + 1

        'Verifica la esquina Derecha Superior
        If i > 0 Then
            Debug.Print Picture1.hdc, lWidth * (i + 1) - 1, 0
            vArrColores(vCont) = GetPixel(Picture1.hdc, lWidth * (i + 1) - 1, 0)
        Else
            Debug.Print Picture1.hdc, lWidth - 1, 0
            vArrColores(vCont) = GetPixel(Picture1.hdc, lWidth - 1, 0)
        End If

        vCont = vCont + 1

        'Verifica la esquina Derecha Inferior
        If i > 0 Then
            Debug.Print Picture1.hdc, lWidth * (i + 1) - 1, lHeight - 1
            vArrColores(vCont) = GetPixel(Picture1.hdc, lWidth * (i + 1) - 1, lHeight - 1)
        Else
            Debug.Print Picture1.hdc, lWidth - 1, lHeight - 1
            vArrColores(vCont) = GetPixel(Picture1.hdc, lWidth - 1, lHeight - 1)
        End If

        vCont = vCont + 1

        Debug.Print ""
    Next

    Call Ordenar_Matriz(vArrColores, LBound(vArrColores), UBound(vArrColores) - 1)
   
    Debug.Print "------------RESULTADO COLORES------------"
   
    Dim q As Integer
    Dim vColorTemp As Long
    Dim vContTemp As Long
       
    Do Until q = UBound(vArrColores) - 1
   
        vColorTemp = vArrColores(q)
        vContTemp = 0
       
        Do Until vColorTemp <> vArrColores(q)
            vContTemp = vContTemp + 1
            If q <> UBound(vArrColores) - 1 Then q = q + 1
        Loop
     
        Debug.Print "COLOR " & vColorTemp & " REPETIDO: " & vContTemp & " VECES"
    Loop
End Sub

Private Sub Ordenar_Matriz(El_Vector() As Variant, Limite_Inferior As Long, Limite_Superior As Long)

    Dim i As Long, j As Long, x As Variant, y As Variant
   
    i = Limite_Inferior
    j = Limite_Superior
   
    x = El_Vector((Limite_Inferior + Limite_Superior) / 2)
   
    While i <= j
       
        While (El_Vector(i) < x) And (i < Limite_Superior)
            i = i + 1
        Wend
       
        While (x < El_Vector(j)) And (j > Limite_Inferior)
            j = j - 1
        Wend
       
        If i <= j Then
            y = El_Vector(i)
            El_Vector(i) = El_Vector(j)
            El_Vector(j) = y
            i = i + 1
            j = j - 1
        End If
   
    Wend
   
    If Limite_Inferior < j Then Ordenar_Matriz El_Vector(), Limite_Inferior, j
    If i < Limite_Superior Then Ordenar_Matriz El_Vector(), i, Limite_Superior
End Sub


saludos.

[LeandroA]

Aca esta mi función

Código (Vb) [Seleccionar] Expandir


Option Explicit
Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long

Private Type BuferColor
    Color As Long
    Count As Long
End Type

Private Sub Form_Load()
    Picture1.AutoRedraw = True
    Me.BackColor = GetMaskColor(Picture1)
End Sub

Private Function GetMaskColor(oPic As PictureBox) As Long
    Dim i As Long, j As Long, x As Long
    Dim lWidth As Long, lHeight As Long
    Dim NumIcon As Long
    Dim aColors() As Long
    Dim BC() As BuferColor
    Dim bFind As Boolean
    Dim lMax As Long, ArrSize As Long
   
    lWidth = (oPic.ScaleWidth \ oPic.ScaleHeight)
    If lWidth = 0 Then lWidth = 1
    lWidth = oPic.ScaleWidth \ lWidth
    lHeight = oPic.ScaleHeight
   
    NumIcon = oPic.ScaleWidth \ lWidth
   
    ArrSize = (NumIcon * 4) - 1
   
    ReDim aColors(ArrSize)

   
    For i = 0 To NumIcon - 1
        aColors(j) = GetPixel(oPic.hdc, x, 0)
        aColors(j + 1) = GetPixel(oPic.hdc, x + lWidth - 1, 0)
        aColors(j + 2) = GetPixel(oPic.hdc, x, lHeight - 1)
        aColors(j + 3) = GetPixel(oPic.hdc, x + lWidth - 1, lHeight - 1)
        j = j + 4
        x = x + lWidth
    Next
   
    ReDim BC(ArrSize)
    x = 0
   
    For i = 0 To ArrSize
       bFind = False
       For j = 0 To x
            If BC(j).Color = aColors(i) Then
                BC(j).Count = BC(j).Count + 1
                bFind = True
                Exit For
            End If
       Next
       If Not bFind Then BC(x).Color = aColors(i): x = x + 1
    Next

    For i = 0 To x - 1
        If BC(i).Count > lMax Then
            lMax = BC(i).Count
            GetMaskColor = BC(i).Color
        End If
    Next

End Function


Seba la idea es obtener un color final, puede que alla un empate en la cantidad de colores  pero almenos es una aproximación

Saludos.