Mensajes

[no]

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.

PD: quedo bueno el Efecto

Saludos.

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

Que


jajaj sos malo cuando queres

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.

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

Esta de Diez pero... "URLDownloadToFile" no hace saltar la Heuristica de bastantes antivirus??

si, puse esa api por practicidad pero se puede usar cual quier otro metodo para descargar, por ejemplo este

Saludos.

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 original

Código (Vb) [Seleccionar] Expandir


Option 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.

Quedo muy bueno che felizitaciones y espero que ganes o almenos empates con Raul que tambien me gusto mucho su mensagero.

Saludos y suerte.

hola no se puede poner valores grandes solo hasta 17

Código [Seleccionar] Expandir

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.

bien acavo de encontrar estas apis en PSC LookupAccountSid , WTSEnumerateProcesses que parecen las adecuada para el Nombre de usuario