|
151
|
Programación / Programación Visual Basic / Re: [Source] Funciones para marcar contornos de una imagen y marcar piel.
|
en: 7 Diciembre 2010, 01:54 am
|
che interesante lo de reconocimiento facial (no digo de quien es la persona por que es muy muy complicado) sino de que encuentre un rostro dentro de una imagen tal como lo hacen las cámaras digitales.
me encantaría saber cual es la lógica para lograrlo, tengo mis dudas sobre el color piel ya que eso es muy complicado deducirlo según la iluminación y el color de piel de la persona.
yo a mi parecer se basa en los ojos y la nariz, hice una prueba con mi cámara y veo que no reconoce si la persona esta de perfil. de frente si te tapas la boca y la frente te reconoce igual, si te tapas la nariz o los ojos no.
si me llego a enterar de algo te aviso.
pd: ese código compilado es mucho mas rápido, igualmente nunca va a alcanzar la velocidad de C o ASM, muchos para estas cosas utiliza ASM +VB es super rápido, pero no tengo ni idea
Saludos.
|
|
|
154
|
Programación / Programación Visual Basic / Re: [Ayuda]Reconocer contornos Picturebox
|
en: 3 Diciembre 2010, 17:17 pm
|
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.
|
|
|
155
|
Programación / Programación Visual Basic / Re: Valium 1.0 [Manda a tu pc a dormir]
|
en: 2 Diciembre 2010, 05:14 am
|
jajaja esta me mato, es para tu nueva firma BlackZeroX▓▓▒▒░░ Me Vale si otros creen en la Existencia de un Dios. The Dark Shadow is my passion. El infierno es mi Hogar, mi novia es Lilith y el metal mi religión Me duermo con las canciones del El topo yiyo A la caminita a la camitaaaa..
|
|
|
157
|
Programación / Programación Visual Basic / [SPINET]Google Speak
|
en: 1 Diciembre 2010, 06:28 am
|
Holas, esta es una simple función para utilizar el api de google speak, sirve para llevar un texto a vos, el apis se limita solo a 100 caracteres, cuenta con tres parámetros el primero es el texto a pronunciar, el segundo la acentuación (español ="es"), y el tercero para llamar a DoEvents si se quiere. Fuente originalOption Explicit '----------------------------------------------------------------------------------------------------- 'Autor: Leandro Ascierto 'Web: www.leandroascierto.com.ar 'Abreviaturas 'de, da, es, fi, fr, en, it, nl, pl, pt, sv" 'Alemán , Danés, Español, Finlandia, Francés, Inglés, Italiano, Neerlandés, Polaco, Portugués, Sueco '---------------------------------------------------------------------------------------------------- Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long Public Function GoogleSpeak(ByVal sText As String, Optional ByVal Language As String = "es", Optional ByVal bDoevents As Boolean) As Boolean On Error Resume Next Dim sTempPath As String, ml As String Dim FileLength As Long sText = Replace(sText, vbCrLf, " ") If Len(sText) > 100 Then Exit Function sTempPath = Environ("Temp") & "\TempMP3.MP3" If URLDownloadToFile(0&, "http://translate.google.com/translate_tts?tl=" & Language & "&q=" & sText, sTempPath, 0&, 0&) = 0 Then If mciSendString("open " & Chr$(34) & sTempPath & Chr$(34) & " type MpegVideo" & " alias myfile", 0&, 0&, 0&) = 0 Then ml = String(30, 0) Call mciSendString("status myfile length ", ml, 30, 0&) FileLength = Val(ml) If FileLength Then If mciSendString("play myFile", 0&, 0&, 0&) = 0 Then Do While mciSendString("status myfile position ", ml, 30, 0&) = 0 If Val(ml) = FileLength Then GoogleSpeak = True: Exit Do If bDoevents Then DoEvents Loop End If End If Call mciSendString("close myfile", 0&, 0&, 0&) End If Kill sTempPath End If End Function Private Sub Command1_Click() Debug.Print GoogleSpeak("Antes era sexo droga y rock and roll, ahora es paja mate y chamame", "es", True) Debug.Print GoogleSpeak("Siamo fuori della copa. un giorno tristissimo", "it", True) End Sub
Saludos.
|
|
|
159
|
Programación / Programación Visual Basic / Re: [RETO] Matriz Bidimensional {FrogMatrix algorithm}
|
en: 29 Noviembre 2010, 17:06 pm
|
hola no se puede poner valores grandes solo hasta 17 Option Explicit
Private Sub Form_Load() Dim M() As Long Dim lVal As Long, x As Long, y As Long lVal = 7 M = CreateMatrix(lVal) For y = 0 To lVal - 1 For x = 0 To lVal - 1 Debug.Print M(x, y), Next Debug.Print Next
End Sub
Private Function CreateMatrix(ByVal Val As Long) As Long() Dim M() As Long Dim x As Long, y As Long, i As Long Dim lSum As Long, lSize As Long If Val > 17 Or Val < 1 Then Exit Function lSize = Val - 1 ReDim M(lSize, lSize) For x = 0 To lSize M(x, 0) = x Next For y = 1 To lSize For x = 0 To lSize If x + y > lSize Then M(x, y) = M(x, y - 1) Else lSum = 0 For i = x To y + x lSum = lSum + M(i, y - 1) Next M(x, y) = lSum End If Next Next CreateMatrix = M
End Function saludos.
|
|
|
|
|
|
|