elhacker.net cabecera Bienvenido(a), Visitante. Por favor Ingresar o Registrarse
¿Perdiste tu email de activación?.

 

 


Tema destacado: Guía rápida para descarga de herramientas gratuitas de seguridad y desinfección


+  Foro de elhacker.net
|-+  Programación
| |-+  Programación General
| | |-+  .NET (C#, VB.NET, ASP)
| | | |-+  Programación Visual Basic (Moderadores: LeandroA, seba123neo)
| | | | |-+  [SRC] Garabatos [by *PsYkE1*]
0 Usuarios y 1 Visitante están viendo este tema.
Páginas: [1] Ir Abajo Respuesta Imprimir
Autor Tema: [SRC] Garabatos [by *PsYkE1*]  (Leído 2,184 veces)
Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
[SRC] Garabatos [by *PsYkE1*]
« en: 16 Mayo 2010, 11:54 am »

Hola buenas, aqui os presento mi ultimo invento :laugh::
Hacer garabatos de colores en tu formulario, es simple, pero me gusta el efecto... :)
Al cabo de unos seg tendriamos algo asi:


o así:
 

Bueno aqui va el codigo, es la cosa mas estupida que podais imaginar:
Necesitamos añadir:

* Un Timer
* Un ScrollBar
* Tres CommandButton (con una matriz)
* Un Label

Código
  1. ' ////////////////////////////////////////////////////////////////
  2. ' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
  3. ' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
  4. ' // respete la autoria y se me comuniquen esos cambios.        //
  5. ' // *Agradecimientos a BlackZeroX.                             //
  6. ' // *Visita http://foro.rthacker.net                           //
  7. ' ////////////////////////////////////////////////////////////////
  8.  
  9. '\\Variables
  10. Dim R1 As Integer, R2 As Integer, R3 As Integer, R4 As Integer
  11. Dim C1 As Integer, C2 As Integer, C3 As Integer
  12. Dim L As Integer
  13. Dim Relleno As Boolean
  14. Dim Que As Variant
  15.  
  16. Private Sub Form_Load()
  17.    ' Pongo titulo al Form
  18.    Me.Caption = "*PsYkE1* - Garabatos"
  19.    ' Asigno el caption a cada botón
  20.    Command1(0).Caption = "Parar"
  21.    Command1(1).Caption = "Rellenos"
  22.    Command1(2).Caption = "Salir"
  23. End Sub
  24.  
  25. Private Sub HScroll1_Scroll()
  26.    ' El intervalo del Timer sea igual a el Value del ScrollBar
  27.    Timer1.Interval = HScroll1.Value
  28.    ' El Value del ScrollBar me aparezca en el Label1
  29.    Label1.Caption = HScroll1.Value
  30. End Sub
  31.  
  32. Private Sub Command1_Click(Index As Integer)
  33.    'Segun el Index asigno unos comandos a cada botón
  34.    Select Case Index
  35.        '\\Parar
  36.        Case 0
  37.            ' Limpio el Form
  38.            Me.Cls
  39.            ' Depende del Caption hace una cosa u otra
  40.            If Command1(0).Caption = "Parar" Then
  41.                MsgBox "Se han quitado los garabatos de tu Formulario", vbInformation, "*PsYkE1* - Garabatos"
  42.                Timer1.Enabled = False
  43.                Command1(0).Caption = "Comenzar"
  44.            Else
  45.                Timer1.Enabled = True
  46.                Command1(0).Caption = "Parar"
  47.            End If
  48.        '\\Rellenos
  49.        Case 1
  50.            ' Limpio el Form
  51.            Me.Cls
  52.            Timer1.Enabled = True
  53.            Command1(0).Caption = "Parar"
  54.            ' Depende del Caption hace una cosa u otra
  55.            If Command1(1).Caption = "Rellenos" Then
  56.                Relleno = True
  57.                MsgBox "Ahora se hará con rectangulos opacos", vbInformation, "*PsYkE1* - Garabatos"
  58.                Command1(1).Caption = "Huecos"
  59.            Else
  60.                Relleno = False
  61.                MsgBox "Se han quitado los garabatos de tu Formulario", vbInformation, "*PsYkE1* - Garabatos"
  62.                Command1(1).Caption = "Rellenos"
  63.            End If
  64.        '\\Salir
  65.        Case 2
  66.            ' Si el Timer esta activado pregunta si quieres salir
  67.            If Timer1.Enabled = True Then
  68.                Que = MsgBox("¿Deseas salir?", vbQuestion + vbYesNo, "*PsYkE1* - Garabatos")
  69.                ' Si dices SI sales del programa
  70.                If Que = vbYes Then End
  71.            End If
  72.        End Select
  73.  
  74. End Sub
  75.  
  76. Private Sub Timer1_Timer() ' Cada 5 milisegundos
  77.  
  78. ' Etiqueta Rndm
  79. Rndm:
  80.  
  81.    ' Para que me salgan números aleatorios
  82.    Randomize
  83.  
  84.    With Me ' Con el formulario actual
  85.        ' Coordenada x del punto de partida
  86.        ' dentro del alto del Form
  87.        R1 = Int(Rnd * .Height)
  88.        ' Coordenada y del punto de partida
  89.        ' dentro del alto del Form
  90.        R2 = Int(Rnd * .Height)
  91.        ' Coordenada x del punto final
  92.        ' dentro del ancho del Form
  93.        R3 = Int(Rnd * .Width)
  94.        ' Coordenada y del punto final
  95.        ' dentro del ancho del Form
  96.        R4 = Int(Rnd * .Width)
  97.    End With
  98.  
  99.    ' Si las coordenadas de partida coinciden con las finales voy a la etiqueta Rndm
  100.    If R1 = R3 And R2 = R4 Then GoTo Rndm
  101.  
  102.    ' Tres números aleatorios para definir el color de nuestra futura linea
  103.    C1 = Int(Rnd * 255)
  104.    C2 = Int(Rnd * 255)
  105.    C3 = Int(Rnd * 255)
  106.  
  107.    If Relleno = False Then
  108.        L = Int(Rnd * 3 + 1)
  109.        If L = 1 Then
  110.            Line (R1, R2)-(R3, R4), RGB(C1, C2, C3) ' Lineas
  111.        ElseIf L = 2 Then
  112.            Circle (R1, R2), (R3), RGB(C1, C2, C3) ' Circulos
  113.        Else
  114.            Line (R1, R2)-(R3, R4), RGB(C1, C2, C3), B ' Rectándulos
  115.        End If
  116.    Else
  117.        Line (R1, R2)-(R3, R4), RGB(C1, C2, C3), BF ' Rectangulos rellenos
  118.    End If
  119.  
  120. End Sub

Descargalo en http://www.mediafire.com/?yymmaefy1ey

Espero que os haya gustado...  :P

Salu2! :)


« Última modificación: 2 Junio 2010, 13:50 pm por *PsYkE1* » En línea

BlackZeroX
Wiki

Desconectado Desconectado

Mensajes: 3.158


I'Love...!¡.


Ver Perfil WWW
Re: [SRC] Garabatos [by *PsYkE1*]
« Respuesta #1 en: 16 Mayo 2010, 19:12 pm »



http://foro.elhacker.net/programacion_visual_basic/lineas_al_aire-t281968.0.html;msg1389871#msg1389871


Dulces Lunas!¡.


En línea

The Dark Shadow is my passion.
Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
Re: [SRC] Garabatos [by *PsYkE1*]
« Respuesta #2 en: 16 Mayo 2010, 19:18 pm »

Gracias, no tenia ni idea, solo fue un experimento... :laugh:
Voy a mirar eso... :)

Salu2! ;)
En línea

BlackZeroX
Wiki

Desconectado Desconectado

Mensajes: 3.158


I'Love...!¡.


Ver Perfil WWW
Re: [SRC] Garabatos [by *PsYkE1*]
« Respuesta #3 en: 16 Mayo 2010, 19:19 pm »

perdonen aqui dejo la modificacion que nunca hice y que en si es la correcta

Código
  1.  
  2.  
  3. Option Explicit
  4.  
  5. '   //  GetSystemMetrics
  6. Const SM_CXSCREEN = 0 'X Size of screen
  7. Const SM_CYSCREEN = 1 'Y Size of Screen
  8. '   //  CreatePen
  9. Const PS_DOT = 2
  10. Const PS_SOLID = 0
  11. '   //  Apis
  12. Private Declare Function GetDesktopWindow Lib "user32" () As Long
  13. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  14. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  15. Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
  16. Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  17. Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  18. Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  19. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  20.  
  21. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  22. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  23.  
  24. Private Type RECT
  25.    Left As Long
  26.    Top As Long
  27.    Right As Long
  28.    Bottom As Long
  29. End Type
  30. Private Type POINTAPI
  31.    x                   As Long
  32.    y                   As Long
  33. End Type
  34. Private Type tLineas
  35.    PuntoInicio         As POINTAPI
  36.    PuntoFinal          As POINTAPI
  37. End Type
  38. Dim RegionWindows       As RECT
  39. Dim hdcDestino          As Long
  40. Dim hdwdestop           As Long
  41.  
  42. Private Sub Form_Load()
  43.    Hide
  44.    '   //  Región/Resolución de Pantalla
  45.    With RegionWindows
  46.        .Bottom = GetSystemMetrics(SM_CYSCREEN)
  47.        .Left = 1
  48.        .Right = GetSystemMetrics(SM_CXSCREEN)
  49.        .Top = 1
  50.    End With
  51.    hdwdestop = GetDesktopWindow
  52.    hdcDestino = GetDC(hdwdestop)
  53.    Timer1.Interval = 100
  54.    Timer1.Enabled = True
  55. End Sub
  56.  
  57. Private Sub Form_Unload(Cancel As Integer)
  58.    Call ReleaseDC(hdwdestop, hdcDestino)
  59. End Sub
  60.  
  61. Private Sub Timer1_Timer()
  62. Dim Linea               As tLineas
  63. Dim hPen                As Long
  64.    '   //  Dibujamos lineas al Azar
  65.        '   //  Calculamos el Punto de Inicio
  66.    Linea.PuntoInicio.x = NumeroAleatorio(RegionWindows.Left, RegionWindows.Right)
  67.    Linea.PuntoInicio.y = NumeroAleatorio(RegionWindows.Top, RegionWindows.Bottom)
  68.        '   //  Calculamos el Punto Final
  69.    Linea.PuntoFinal.x = NumeroAleatorio(RegionWindows.Left, RegionWindows.Right)
  70.    Linea.PuntoFinal.y = NumeroAleatorio(RegionWindows.Top, RegionWindows.Bottom)
  71.    '   //  Dibujamos la Linea
  72.    '   //  Dibujamos los puntos    Inicio y Final en color rojo
  73.        '   //  Color de la Linea
  74.        hPen = CreatePen(PS_SOLID, 1, vbRed)
  75.        Call DeleteObject(SelectObject(hdcDestino, hPen))
  76.        Ellipse hdcDestino, Linea.PuntoInicio.x - 2, Linea.PuntoInicio.y - 2, Linea.PuntoInicio.x + 2, Linea.PuntoInicio.y + 2
  77.        Ellipse hdcDestino, Linea.PuntoFinal.x - 2, Linea.PuntoFinal.y - 2, Linea.PuntoFinal.x + 2, Linea.PuntoFinal.y + 2
  78.        Call DeleteObject(hPen)
  79.        '   //  Color de la Linea
  80.        hPen = CreatePen(PS_SOLID, 1, (RGB(NumeroAleatorio(0, 255), NumeroAleatorio(0, 255), NumeroAleatorio(0, 255))))
  81.        Call DeleteObject(SelectObject(hdcDestino, hPen))
  82.        '   //  Iniciamos una nueva Linea (Punto de Inicio)
  83.        MoveToEx hdcDestino, Linea.PuntoInicio.x, Linea.PuntoInicio.y, ByVal 0&
  84.        '   //  Finalizamos la Linea (Punto Final)
  85.        LineTo hdcDestino, Linea.PuntoFinal.x, Linea.PuntoFinal.y
  86.        DeleteObject hPen
  87. End Sub
  88. Public Function NumeroAleatorio(MinNum As Long, MaxNum As Long) As Long
  89. Dim Tmp                                 As Long
  90.    If MaxNum < MinNum Then: Tmp = MaxNum: MaxNum = MinNum: MinNum = Tmp
  91.    Randomize: NumeroAleatorio = CLng((MinNum - MaxNum + 1) * Rnd + MaxNum)
  92. End Function
  93.  
  94.  

Dulce Infierno Lunar!¡.
En línea

The Dark Shadow is my passion.
BlackZeroX
Wiki

Desconectado Desconectado

Mensajes: 3.158


I'Love...!¡.


Ver Perfil WWW
Re: [SRC] Garabatos [by *PsYkE1*]
« Respuesta #4 en: 16 Mayo 2010, 19:39 pm »


una correccion

Código
  1. Dim Que As Variant
  2.  

Deberia ser

Código
  1. Private Que As VbMsgBoxResult
  2.  

o mas sencillo metelo directamente en el

Código
  1. if msgbox(...) = vbyes then
  2. ...
  3. end if
  4.  

lo que devuelve no ocupa mas de 1 byte asi que podrias ponerlo en un byte y no en un vvariant que ocupa mas de 6 bytes (no recuerdo cuantyos esactamente).

P.D.: Cuando escribes msgbox vb6 te da la sintansis y al ultimo aparece as <TIPO>  el tipo es lo devuelto.

Dulce Infierno Lunar!¡.
En línea

The Dark Shadow is my passion.
Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
Re: [SRC] Garabatos [by *PsYkE1*]
« Respuesta #5 en: 16 Mayo 2010, 19:42 pm »

Muchas gracias!!!!!!!!! ;-) ;-) ;-) ;-) ;-) ;-) ;-) ;-) ;-) ;-)
no pasara para la proxima!!!!!!! ;)

Salu2! :D
En línea

BlackZeroX
Wiki

Desconectado Desconectado

Mensajes: 3.158


I'Love...!¡.


Ver Perfil WWW
Re: [SRC] Garabatos [by *PsYkE1*]
« Respuesta #6 en: 16 Mayo 2010, 19:43 pm »

se me olvido prueba con esto:

Código
  1. Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  2.    Cancel = Not MsgBox("salir realmente", vbOKCancel) = vbOK
  3. End Sub
  4.  

Dulces Lunas!¡.
En línea

The Dark Shadow is my passion.
Psyke1
Wiki

Desconectado Desconectado

Mensajes: 1.089



Ver Perfil WWW
Re: [SRC] Garabatos [by *PsYkE1*]
« Respuesta #7 en: 16 Mayo 2010, 19:46 pm »

Ok, gracias a postear mi code he aprendido mucho... ;D
Lo corregire en breves...
Una vez más:
Gracias BlackZeroX▓▓▒▒░░ :-*  :xD
En línea

Páginas: [1] Ir Arriba Respuesta Imprimir 

Ir a:  

Mensajes similares
Asunto Iniciado por Respuestas Vistas Último mensaje
[ahora SI funciona] [SRC] + [Módulo] Persianas [VB6] [by *PsYkE1*] « 1 2 »
Programación Visual Basic
Psyke1 14 6,281 Último mensaje 13 Mayo 2010, 12:32 pm
por Psyke1
WAP2 - Aviso Legal - Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines