Funciones para marcar contornos de una imagen y marcar piel.

Iniciado por 79137913, Febrero 01, 2013, 08:17:40 PM

Tema anterior - Siguiente tema

0 Miembros y 1 Visitante están viendo este tema.

Febrero 01, 2013, 08:17:40 PM Ultima modificación: Enero 14, 2015, 08:16:30 PM por Expermicid
HOLA!!!

Bueno, este es el primer codigo de la semana empiezo con algo complicado  que va a requerir mucho nivel del programador que lo lea, ya que estamos entrando en un tema de reconocimiento de imagenes, en este caso, ROSTROS.

En este post esta el codigo y el ejemplo de como pixel por pixel ir recorriendo una imagen y marcar todos los bordes mediante reconocimiento de diferencia de tonalidad y sombras, ademas, tambien hay otra funcion que reconoce los pixels que estan en el espectro de colores de la piel humana (de caucasico a hispano).

LO MAS IMPORTANTE:

No tengan miedo de preguntar como funciona, que lo que mas quiero es que aprendan.

Gracias a LEANDROA pude armar una funcion que convierte una imagen cualquiera a una imagen en ByN puro sin escala de grises marcando solamente los contornos de las cosas.

Hay una variable "Tolerance" esa la regulan para que sea mas o menos estricto con la deteccion de bordes.

Bueno aca el codigo (Modulo):
Código: vb
Option Explicit
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO24, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO24
    bmiHeader As BITMAPINFOHEADER
    bmiColors() As RGBQUAD
End Type

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type

Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type


Private Const DIB_RGB_COLORS = 0
Private Const BI_RGB = 0&


Public Sub BuscarContornos(Pic As PictureBox)
    Dim BytesPerLine As Long
    Dim WinDC As Long
    Dim TmpDC As Long
    Dim hBmp As Long
    Dim OldBmp As Long
    Dim Addrs As Long
    Dim x As Long
    Dim y As Long
    Dim lpBits() As Byte
    Dim M_BitmapInfo As BITMAPINFO24
    Dim SA As SAFEARRAY2D
    Dim R As Byte, G As Byte, B As Byte, BYN As Byte, Tolerance As Byte
    Dim ZERO As Integer
    Dim tmp1 As Integer, tmp2 As Integer, tmp3 As Integer
    Tolerance = 20
    ZERO = 0
    BytesPerLine = ScanAlign(Pic.ScaleWidth * 3)

    With M_BitmapInfo.bmiHeader
        .biSize = Len(M_BitmapInfo.bmiHeader)
        .biWidth = Pic.ScaleWidth
        .biHeight = Pic.ScaleHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerLine * Pic.ScaleHeight
    End With

    WinDC = GetDC(0)
    TmpDC = CreateCompatibleDC(WinDC)
    hBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0)

    Call ReleaseDC(0, WinDC)

    With SA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = Pic.ScaleHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerLine
        .pvData = Addrs
    End With

    CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4

    OldBmp = SelectObject(TmpDC, hBmp)

    Call BitBlt(TmpDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hDC, 0, 0, vbSrcCopy)

    For y = 0 To Pic.ScaleHeight - 1
        For x = 0 To (Pic.ScaleWidth * 3) - 1 Step 3

            B = lpBits(x + 2, y)
            G = lpBits(x + 1, y)
            R = lpBits(x, y)


            'ZERO ES PARA QUE NO HAGA DESBORDAMIENTO
            BYN = Int((ZERO + R + G + B) / 3)
           
            'DIBUJA EN BLANCO Y NEGRO
           
            lpBits(x, y) = BYN
            lpBits(x + 1, y) = BYN
            lpBits(x + 2, y) = BYN
            If x <> 0 And y <> 0 Then
            tmp1 = lpBits(x - 1, y - 1)
            tmp2 = lpBits(x - 1, y)
            tmp3 = lpBits(x, y - 1)
            If Abs(tmp2 - tmp1) > Tolerance Or Abs(tmp3 - tmp1) > Tolerance Then
                lpBits(x - 1, y - 1) = 0
                lpBits(x - 2, y - 1) = 0
                lpBits(x - 3, y - 1) = 0
            Else
                'PINTA DE NEGRO EL PIXEL POR QUE AHI HAY UN BORDE
                lpBits(x - 1, y - 1) = 255
                lpBits(x - 2, y - 1) = 255
                lpBits(x - 3, y - 1) = 255
            End If
            End If
        Next x
    Next y

    CopyMemory ByVal VarPtrArray(lpBits), 0&, 4
    Call BitBlt(Pic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, TmpDC, 0, 0, vbSrcCopy)
    Call DeleteObject(SelectObject(TmpDC, OldBmp))
    Call DeleteDC(TmpDC)



End Sub

Public Sub BuscarPiel(Pic As PictureBox)
    Dim BytesPerLine As Long
    Dim WinDC As Long
    Dim TmpDC As Long
    Dim hBmp As Long
    Dim OldBmp As Long
    Dim Addrs As Long
    Dim x As Long
    Dim y As Long
    Dim lpBits() As Byte
    Dim M_BitmapInfo As BITMAPINFO24
    Dim SA As SAFEARRAY2D
    Dim R As Byte, G As Byte, B As Byte, BYN As Byte, Tolerance As Byte
    Dim ZERO As Integer
    Dim tmp1 As Integer, tmp2 As Integer, tmp3 As Integer
    Tolerance = 20
    ZERO = 0
    BytesPerLine = ScanAlign(Pic.ScaleWidth * 3)

    With M_BitmapInfo.bmiHeader
        .biSize = Len(M_BitmapInfo.bmiHeader)
        .biWidth = Pic.ScaleWidth
        .biHeight = Pic.ScaleHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerLine * Pic.ScaleHeight
    End With

    WinDC = GetDC(0)
    TmpDC = CreateCompatibleDC(WinDC)
    hBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0)

    Call ReleaseDC(0, WinDC)

    With SA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = Pic.ScaleHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerLine
        .pvData = Addrs
    End With

    CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4

    OldBmp = SelectObject(TmpDC, hBmp)

    Call BitBlt(TmpDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hDC, 0, 0, vbSrcCopy)

    For y = 0 To Pic.ScaleHeight - 1
        For x = 0 To (Pic.ScaleWidth * 3) - 1 Step 3

            R = lpBits(x + 2, y)
            G = lpBits(x + 1, y)
            B = lpBits(x, y)


            'ZERO ES PARA QUE NO HAGA DESBORDAMIENTO
            BYN = Int((ZERO + R + G + B) / 3)
           
            'DIBUJA EN BLANCO Y NEGRO
            If R > 168 And G > 134 And B > 94 And R < 250 And G < 235 And B < 215 Then
            ' LOS PROXIMOS 3 VALORES ESPECIFICAN EL COLOR CON EL QUE SE VA A PINTAR
            lpBits(x, y) = 0
            lpBits(x + 1, y) = 255
            lpBits(x + 2, y) = 255
            Else
            lpBits(x, y) = 0 ' BYN
            lpBits(x + 1, y) = 0 'BYN
            lpBits(x + 2, y) = 0 'BYN
            End If
        Next x
    Next y

    CopyMemory ByVal VarPtrArray(lpBits), 0&, 4
    Call BitBlt(Pic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, TmpDC, 0, 0, vbSrcCopy)
    Call DeleteObject(SelectObject(TmpDC, OldBmp))
    Call DeleteDC(TmpDC)



End Sub

Private Function ScanAlign(WidthBmp As Long) As Long
    ScanAlign = (WidthBmp + 3) And &HFFFFFFFC
End Function



Para llamar la funcion:
Código: vb
Private Sub Command1_Click()
    'ESTO PARA CONTORNOS
    BuscarContornos PicTratamiento
    'ESTO PARA PIEL
    BuscarPiel PicTratamiento
    PicTratamiento.Refresh
End Sub

Private Sub Form_Load()
    PicTratamiento.AutoRedraw = True
    PicTratamiento.ScaleMode = vbPixels
End Sub


P.D: El de la foto soy yo asi que no puteen.
GRACIAS POR LEER!!!
"Algunos creen que soy un bot, puede que tengan razon"
"Como no se puede igualar a Dios, ya he decidido que hacer, ¡SUPERARLO!"
"La peor de las ignorancias es no saber corregirlas"

*Shadow Scouts Team*                                                No tienes permitido ver los links. Registrarse o Entrar a mi cuenta

Como funciona?, no entiendo, perdon, se que es algo antiguo el post, pero lo estaba viendo y me llamo la atencion :P
saludos numeritos
Tener éxito no es aleatorio, es una variable dependiente del esfuerzo.

HOLA!!!

Lo que hacen las funciones es lo siguiente:
Contorno:
Busca diferencia entre pixels con X tolerancia, si la diferencia es mayor a X marca en negro, sino en blanco.

BuscarPiel:
Busca las tonalidades estandares de piel, con X tolerancia, si los valores se encuentran en el ratio pinta de amarillo, sino de blanco.(no funciona con gente de la etnia "negra")

De esta manera luego solo nos queda identificar las zonas amarillas de las fotos y/o verificar las figuras formadas por los bordes negros.

GRACIAS POR LEER!!!
"Algunos creen que soy un bot, puede que tengan razon"
"Como no se puede igualar a Dios, ya he decidido que hacer, ¡SUPERARLO!"
"La peor de las ignorancias es no saber corregirlas"

*Shadow Scouts Team*                                                No tienes permitido ver los links. Registrarse o Entrar a mi cuenta