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 :P) hacen un call a la funcion y listo.
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!!!
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
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
Private Sub Command1_Click()
BuscarContornos PicTratamiento
PicTratamiento.Refresh
End Sub
Private Sub Form_Load()
PicTratamiento.AutoRedraw = True
PicTratamiento.ScaleMode = vbPixels
End Sub
Saludos.
HOLA!!!
;-) ;-) ;-) ;-) ;-)
Gracias LEA!!!
Me ayudaste un monton, me sirve mucho gracias :D
GRACIAS POR LEER!!!