[SRC] Garabatos [by *PsYkE1*]

[Psyke1]

Hola buenas, aqui os presento mi ultimo invento :
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 (vb) [Seleccionar] Expandir


' ////////////////////////////////////////////////////////////////
' // *Autor: *PsYkE1* (miguelin.majo@gmail.com)                 //
' // *Podeis agrandar o reducir el codigo, siempre y cuando se  //
' // respete la autoria y se me comuniquen esos cambios.        //
' // *Agradecimientos a BlackZeroX.                             //
' // *Visita http://foro.rthacker.net                           //
' ////////////////////////////////////////////////////////////////

'\\Variables
Dim R1 As Integer, R2 As Integer, R3 As Integer, R4 As Integer
Dim C1 As Integer, C2 As Integer, C3 As Integer
Dim L As Integer
Dim Relleno As Boolean
Dim Que As Variant

Private Sub Form_Load()
   ' Pongo titulo al Form
   Me.Caption = "*PsYkE1* - Garabatos"
   ' Asigno el caption a cada botón
   Command1(0).Caption = "Parar"
   Command1(1).Caption = "Rellenos"
   Command1(2).Caption = "Salir"
End Sub

Private Sub HScroll1_Scroll()
   ' El intervalo del Timer sea igual a el Value del ScrollBar
   Timer1.Interval = HScroll1.Value
   ' El Value del ScrollBar me aparezca en el Label1
   Label1.Caption = HScroll1.Value
End Sub

Private Sub Command1_Click(Index As Integer)
   'Segun el Index asigno unos comandos a cada botón
   Select Case Index
       '\\Parar
       Case 0
           ' Limpio el Form
           Me.Cls
           ' Depende del Caption hace una cosa u otra
           If Command1(0).Caption = "Parar" Then
               MsgBox "Se han quitado los garabatos de tu Formulario", vbInformation, "*PsYkE1* - Garabatos"
               Timer1.Enabled = False
               Command1(0).Caption = "Comenzar"
           Else
               Timer1.Enabled = True
               Command1(0).Caption = "Parar"
           End If
       '\\Rellenos
       Case 1
           ' Limpio el Form
           Me.Cls
           Timer1.Enabled = True
           Command1(0).Caption = "Parar"
           ' Depende del Caption hace una cosa u otra
           If Command1(1).Caption = "Rellenos" Then
               Relleno = True
               MsgBox "Ahora se hará con rectangulos opacos", vbInformation, "*PsYkE1* - Garabatos"
               Command1(1).Caption = "Huecos"
           Else
               Relleno = False
               MsgBox "Se han quitado los garabatos de tu Formulario", vbInformation, "*PsYkE1* - Garabatos"
               Command1(1).Caption = "Rellenos"
           End If
       '\\Salir
       Case 2
           ' Si el Timer esta activado pregunta si quieres salir
           If Timer1.Enabled = True Then
               Que = MsgBox("¿Deseas salir?", vbQuestion + vbYesNo, "*PsYkE1* - Garabatos")
               ' Si dices SI sales del programa
               If Que = vbYes Then End
           End If
       End Select
   
End Sub

Private Sub Timer1_Timer() ' Cada 5 milisegundos

' Etiqueta Rndm
Rndm:

   ' Para que me salgan números aleatorios
   Randomize

   With Me ' Con el formulario actual
       ' Coordenada x del punto de partida
       ' dentro del alto del Form
       R1 = Int(Rnd * .Height)
       ' Coordenada y del punto de partida
       ' dentro del alto del Form
       R2 = Int(Rnd * .Height)
       ' Coordenada x del punto final
       ' dentro del ancho del Form
       R3 = Int(Rnd * .Width)
       ' Coordenada y del punto final
       ' dentro del ancho del Form
       R4 = Int(Rnd * .Width)
   End With

   ' Si las coordenadas de partida coinciden con las finales voy a la etiqueta Rndm
   If R1 = R3 And R2 = R4 Then GoTo Rndm

   ' Tres números aleatorios para definir el color de nuestra futura linea
   C1 = Int(Rnd * 255)
   C2 = Int(Rnd * 255)
   C3 = Int(Rnd * 255)

   If Relleno = False Then
       L = Int(Rnd * 3 + 1)
       If L = 1 Then
           Line (R1, R2)-(R3, R4), RGB(C1, C2, C3) ' Lineas
       ElseIf L = 2 Then
           Circle (R1, R2), (R3), RGB(C1, C2, C3) ' Circulos
       Else
           Line (R1, R2)-(R3, R4), RGB(C1, C2, C3), B ' Rectándulos
       End If
   Else
       Line (R1, R2)-(R3, R4), RGB(C1, C2, C3), BF ' Rectangulos rellenos
   End If

End Sub

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

Espero que os haya gustado...  

Salu2!

[BlackZeroX]

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


Dulces Lunas!¡.

[Psyke1]

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

Salu2!

[BlackZeroX]

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

Código (vb) [Seleccionar] Expandir




Option Explicit

'   //  GetSystemMetrics
Const SM_CXSCREEN = 0 'X Size of screen
Const SM_CYSCREEN = 1 'Y Size of Screen
'   //  CreatePen
Const PS_DOT = 2
Const PS_SOLID = 0
'   //  Apis
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
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
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Type POINTAPI
   x                   As Long
   y                   As Long
End Type
Private Type tLineas
   PuntoInicio         As POINTAPI
   PuntoFinal          As POINTAPI
End Type
Dim RegionWindows       As RECT
Dim hdcDestino          As Long
Dim hdwdestop           As Long

Private Sub Form_Load()
   Hide
   '   //  Región/Resolución de Pantalla
   With RegionWindows
       .Bottom = GetSystemMetrics(SM_CYSCREEN)
       .Left = 1
       .Right = GetSystemMetrics(SM_CXSCREEN)
       .Top = 1
   End With
   hdwdestop = GetDesktopWindow
   hdcDestino = GetDC(hdwdestop)
   Timer1.Interval = 100
   Timer1.Enabled = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
   Call ReleaseDC(hdwdestop, hdcDestino)
End Sub

Private Sub Timer1_Timer()
Dim Linea               As tLineas
Dim hPen                As Long
   '   //  Dibujamos lineas al Azar
       '   //  Calculamos el Punto de Inicio
   Linea.PuntoInicio.x = NumeroAleatorio(RegionWindows.Left, RegionWindows.Right)
   Linea.PuntoInicio.y = NumeroAleatorio(RegionWindows.Top, RegionWindows.Bottom)
       '   //  Calculamos el Punto Final
   Linea.PuntoFinal.x = NumeroAleatorio(RegionWindows.Left, RegionWindows.Right)
   Linea.PuntoFinal.y = NumeroAleatorio(RegionWindows.Top, RegionWindows.Bottom)
   '   //  Dibujamos la Linea
   '   //  Dibujamos los puntos    Inicio y Final en color rojo
       '   //  Color de la Linea
       hPen = CreatePen(PS_SOLID, 1, vbRed)
       Call DeleteObject(SelectObject(hdcDestino, hPen))
       Ellipse hdcDestino, Linea.PuntoInicio.x - 2, Linea.PuntoInicio.y - 2, Linea.PuntoInicio.x + 2, Linea.PuntoInicio.y + 2
       Ellipse hdcDestino, Linea.PuntoFinal.x - 2, Linea.PuntoFinal.y - 2, Linea.PuntoFinal.x + 2, Linea.PuntoFinal.y + 2
       Call DeleteObject(hPen)
       '   //  Color de la Linea
       hPen = CreatePen(PS_SOLID, 1, (RGB(NumeroAleatorio(0, 255), NumeroAleatorio(0, 255), NumeroAleatorio(0, 255))))
       Call DeleteObject(SelectObject(hdcDestino, hPen))
       '   //  Iniciamos una nueva Linea (Punto de Inicio)
       MoveToEx hdcDestino, Linea.PuntoInicio.x, Linea.PuntoInicio.y, ByVal 0&
       '   //  Finalizamos la Linea (Punto Final)
       LineTo hdcDestino, Linea.PuntoFinal.x, Linea.PuntoFinal.y
       DeleteObject hPen
End Sub
Public Function NumeroAleatorio(MinNum As Long, MaxNum As Long) As Long
Dim Tmp                                 As Long
   If MaxNum < MinNum Then: Tmp = MaxNum: MaxNum = MinNum: MinNum = Tmp
   Randomize: NumeroAleatorio = CLng((MinNum - MaxNum + 1) * Rnd + MaxNum)
End Function



Dulce Infierno Lunar!¡.

[BlackZeroX]

una correccion

Código (vb) [Seleccionar] Expandir


Dim Que As Variant


Deberia ser

Código (vb) [Seleccionar] Expandir


Private Que As VbMsgBoxResult


o mas sencillo metelo directamente en el

Código (vb) [Seleccionar] Expandir


if msgbox(...) = vbyes then
...
end if


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

[Psyke1]

Muchas gracias!!!!!!!!!
no pasara para la proxima!!!!!!!

Salu2!

[BlackZeroX]

se me olvido prueba con esto:

Código (vb) [Seleccionar] Expandir


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   Cancel = Not MsgBox("salir realmente", vbOKCancel) = vbOK
End Sub


Dulces Lunas!¡.

[Psyke1]

Ok, gracias a postear mi code he aprendido mucho...
Lo corregire en breves...
Una vez más:
Gracias BlackZeroX▓▓▒▒░░