HOLA!!!

Karcrack: Listo ahi esta la imagen

GRACIAS POR LEER!!!

HOLA!!!

EFECTO:


Gracias a LEANDRO A 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.

AGREGADO: funcion para pintar las zonas que son piel.


Hay una variable "Tolerance" esa la regulan para que sea mas o menos estricto con la deteccion de bordes.

Bueno aca el codigo (Modulo):
Repito GRACIAS LEA!

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

HOLA!!!

 

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

GRACIAS POR LEER!!!

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.

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

MUY BUENOS PROGRAMAS, ME ENCANTARON.

MI PODIO:


                            FrogCheat 
          DLLGenius|        1        |
         |        2                          |Notas por Red 
         |                                                 3          |

GRACIAS POR LEER!!!

HOLA!!!

Usa el DOS, el comando "shutdown"

Si no queres leer tanto usa "shutdown -i" en la ventana ejecutar y te carga la GUI

Uso: shutdown [-l | -s | -r | -a] [-f] [-m \\equipo] [-t xx] [-c "comentario"] [
-d up:xx:yy]

        Sin argumentos  Mostrar este mensaje (igual a -?)
      -i                Mostrar interfaz GUI, debe ser la primera opción
        -l                      Cerrar sesión (no se puede usar con la opción -m
)
        -s                      Apagar el equipo
        -r                      Apagar y reiniciar el equipo
        -a                      Anular el apagado de equipo
        -m \\equipo             Equipo que se apagará/reiniciará/anulara
        -t xx                   Establecer el tiempo de espera de apagado en xx
                               segundos
        -c "comentario"         Comentario de apagado (máximo, 127 caracteres)
        -f                      Fuerza el cierre de aplicaciones sin advertir
        -d [p]:xx:yy         Código de motivo de apagado
                                u es el código de usuario
                                p es el código de apagado planeado
                                xx es el código primario del motivo de apagado
                              (entero positivo menor que 256)
                                yy es el código secundario del motivo de apagado

                              (entero positivo menor que 65536)

Ejemplo shutdown -s -t 3600
Con eso se va  a apagar en 1 hora.
Para cancelar usa shutdown -a

GRACIAS POR LEER!!!

HOLA!!!

ACA LES DEJO MI CODE, MEJORE EL DE LEANDRO A (10% mas rapido en promedio):
(seguro que se puede mejorar la parte que agregue)
si se continua expresando como funcion e imprimiendo las celdas negativas se toma menos tiempo.

Private tmr As CTiming
 
 
Private Function MatriX7913(ByVal N As Integer) As Long()
    Dim M() As Long
    Dim x As Integer, y As Integer, Z As Integer
    Dim AGRUP As Long, TAM As Integer
 
    If N < 1 Then Exit Function
 
    TAM = N - 1
 
    ReDim M(TAM, TAM)
 
    For x = 0 To TAM
        M(x, 0) = x
        M(TAM, x) = TAM
        If TAM > 0 Then
            If Not x = TAM Then
                M(x, 1) = 1 + (x * 2)
                If x = TAM - 2 Then
                    For a = 1 To TAM
                        M(TAM - 1, a) = (TAM * 2) - 1
                    Next
                End If
            End If
        End If
   Next
If TAM > 1 Then
'GRACIAS LEANDRO A
    For y = 2 To TAM
        For x = 0 To (TAM - 2)
            If x + y > TAM Then
                M(x, y) = M(x, y - 1)
            Else
                AGRUP = 0
                For Z = x To y + x
                    AGRUP = AGRUP + M(Z, y - 1)
                Next
                M(x, y) = AGRUP
            End If
        Next
    Next
'GRACIAS LEANDRO A
End If
    MatriX7913 = M
 
End Function
 
Private Sub Form_Load()
  Dim M() As Long
  Dim TAMX As Integer, x As Integer, y As Integer
  Set tmr = New CTiming
 
  TAMX = 17
  For FAF = 1 To 10
  tmr.Reset
  M = MatriX7913(TAMX)
  MsgBox tmr.sElapsed
  Next
  For y = 0 To TAMX - 1
        For x = 0 To TAMX - 1
            Debug.Print M(x, y),
        Next
        Debug.Print
  Next
 
End Sub
 

MOD: lo baje a un 15% 

GRACIAS POR LEER!!!

HOLA!!!

NightMore:
Jajaja, la verdad no entendi nada de lo que digiste, pero gracias  .
Mejor que te haya servido .

GRACIAS POR LEER!!!

HOLA!!!

Hola, para simular los clicks del mouse usa el API MOUSE_EVENT.
Y para escribir un texto la funcion SENDKEYS.

Suerte avisame si necesitas mas info.


GRACIAS POR LEER!!!

HOLA!!!

Pregunta de ignorante, que diferencia tengo en guardar las variables en un *.ini a un archivo de texto plano que no sea *.ini .
Por que yo, en mis programas me manejo con un archivo de texto variables.hip en el cual mediante el index del item me doy cuenta que variable es (leo mediante input).

GRACIAS POR LEER!!!