[Ayuda]Reconocer contornos Picturebox

[79137913]

HOLA!!!

Como andan?, hoy tengo una duda, estoy intentando encontrar los contornos de los objetos de una foto(en un picturebox) logre armar algo buscando en google, pero es  muy inpresiso.

La imagen se trata en un Picturebox chico asi no tarda mucho, sino se come el procesador.

Si encuentran algo o ven algo en mi codigo avisenme.

Bueno, les dejo mi codigo para que lo vean.
Esto va en un modulo y en el Form1 ponen un picturebox con una imagen (chica ) hacen un call a la funcion y listo.

Código (vb) [Seleccionar] Expandir

Public color As Long
Public ElR As Byte
Public ElG As Byte
Public ElB As Byte
Dim P12 As Integer, P21 As Integer, P22 As Integer

Public Sub RGBdelPixel(x As Integer, y As Integer)
   color = Form1.PicTratamiento.Point(x - 1, y)
   ElB = (color \ 65536) And &HFF
   ElG = (color \ 256) And &HFF
   ElR = color And &HFF
   P12 = (70! * ElR + 150! * ElG + 29! * ElB) / 255
   color = Form1.PicTratamiento.Point(x, y - 1)
   ElB = (color \ 65536) And &HFF
   ElG = (color \ 256) And &HFF
   ElR = color And &HFF
   P21 = (70! * ElR + 150! * ElG + 29! * ElB) / 255
   color = Form1.PicTratamiento.Point(x, y)
   ElB = (color \ 65536) And &HFF
   ElG = (color \ 256) And &HFF
   ElR = color And &HFF
   P22 = (70! * ElR + 150! * ElG + 29! * ElB) / 255
End Sub

Public Sub Contornos()
Dim AltUrA As Integer, lArgO As Integer, color As Integer
Dim i As Integer, j As Integer
Form1.PicTratamiento.ScaleMode = 3
AltUrA = Form1.PicTratamiento.ScaleHeight
lArgO = Form1.PicTratamiento.ScaleWidth
tolerancia = 100

For i = 1 To lArgO - 1
    For j = 1 To AltUrA - 1
        RGBdelPixel i, j
        If Abs(P12 - P22) > tolerancia Or Abs(P21 - P22) > tolerancia Then
            Form1.PicTratamiento.PSet (i, j) ', RGB(P22, P22, P22)
        Else
            Form1.PicTratamiento.PSet (i, j), vbWhite
        End If
Next
Next
Form1.PicTratamiento.ScaleMode = 1
End Sub

GRACIAS POR LEER!!!

[LeandroA]

Hola no entiendo bien lo que queres hacer pero te paso una rutina 100 veces mas rapida para trabjar con pixels

fijate que te marque con un comentario donde tens que trata el RGB

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

    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)
           
            '----------------------------------
            '
            'Aca modificas el R,G,B a tu gusto
            '
            '----------------------------------
           
            lpBits(X, Y) = R
            lpBits(X + 1, Y) = G
            lpBits(X + 2, Y) = B
       
        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


Código (vb) [Seleccionar] Expandir


Private Sub Command1_Click()
    BuscarContornos PicTratamiento
    PicTratamiento.Refresh
End Sub

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


Saludos.

[79137913]

HOLA!!!



Gracias LEA!!!
Me ayudaste un monton, me sirve mucho gracias

GRACIAS POR LEER!!!