[Source] Funciones para marcar contornos de una imagen y marcar piel.

[79137913]

HOLA!!!

EFECTO:


Gracias a LEANDRO A 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.

AGREGADO: funcion para pintar las zonas que son piel.


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

Bueno aca el codigo (Modulo):
Repito GRACIAS LEA!

Código (vb) [Seleccionar] Expandir

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) [Seleccionar] Expandir

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!!!

[Karcrack]

Estaria bien poder ver una captura de como queda

[79137913]

HOLA!!!

Karcrack: Listo ahi esta la imagen

GRACIAS POR LEER!!!

[ssccaann43 ©]

Excelente

[79137913]

HOLA!!!

MOD: Agregado funcion para marcar piel.

GRACIAS POR LEER!!!

[Karcrack]

Muy sexy el tio de la foto

Interesante trabajo... pero que utilidad tiene? A parte del efecto, que se puede hacer simplemente con el Photoshop

[LeandroA]

Interesante trabajo... pero que utilidad tiene? A parte del efecto, que se puede hacer simplemente con el Photoshop

Que


jajaj sos malo cuando queres

[LeandroA]

PD: quedo bueno el Efecto

Saludos.

[79137913]

HOLA!!!

Karcrack: La idea no es hacer un programa que haga filtros estilo photoshop la idea es reconocer a las personas por su cara.

Algo asi:


Perdon si no les agrada, solamente queria compartir.

Lo que estoy haciendo para que tengan una idea es:
Traducir el programa que arme en delphi que arme para detectar rostros que aparecen en la webcam, con esas dos funciones lo que hago es fijarme con la de contorno las formas que son parecidas a las caras, y con el filtro de color piel lo que hace es eliminar todas las cosas que tienen forma de cara pero no tienen color piel (perdonen la redundancia). Para que se den una idea en definitiva es un programa que muestra la webcam estilo la camara esa que reconoce rostros, osea muestra un cuadrado al rededor del mismo para luego reconocerlo (la parte de reconocer los rostros es lo que me falta osea quien es).

P.D: Vuelvo a decir gracias LeandroA, pensaba que el vb6 no me iba a dar la velocidad para procesar la imagen  .


GRACIAS POR LEER!!!

[Karcrack]

Solo queria saber si tenia utilidad Y por lo visto la tiene Me encanta el proyecto de reconocimiento facial, mucha suerte