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):
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:
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!!!
Como funciona?, no entiendo, perdon, se que es algo antiguo el post, pero lo estaba viendo y me llamo la atencion :P
saludos numeritos
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!!!