Mensajes

[Karcrack:]

HOLA!!!

Karcrack: Listo ahi esta la imagen

GRACIAS POR LEER!!!

[AGREGADO: funcion para pintar las zonas que son piel.]

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!

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, 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:

Código (vb) [Seleccionar] Expandir

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.

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

[FrogCheat]

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.

Código (vb) [Seleccionar] Expandir

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

[NightMore:]

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