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:
(http://r.i.elhacker.net/cache?url=http://s3.subirimagenes.com:81/otros/previo/thump_4512157sdfgsdfg.jpg)
o así:
(http://r.i.elhacker.net/cache?url=http://s2.subirimagenes.com/otros/previo/thump_4512972nuevo-imagen-de-mapa.jpg)
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
' ////////////////////////////////////////////////////////////////
' // *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... :P
Salu2! :)
http://foro.elhacker.net/programacion_visual_basic/lineas_al_aire-t281968.0.html;msg1389871#msg1389871
Dulces Lunas!¡.
Gracias, no tenia ni idea, solo fue un experimento... :laugh:
Voy a mirar eso... :)
Salu2! ;)
perdonen aqui dejo la modificacion que nunca hice y que en si es la correcta
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!¡.
una correccion
Dim Que As Variant
Deberia ser
Private Que As VbMsgBoxResult
o mas sencillo metelo directamente en el
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!¡.
Muchas gracias!!!!!!!!! ;-) ;-) ;-) ;-) ;-) ;-) ;-) ;-) ;-) ;-)
no pasara para la proxima!!!!!!! ;)
Salu2! :D
se me olvido prueba con esto:
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = Not MsgBox("salir realmente", vbOKCancel) = vbOK
End Sub
Dulces Lunas!¡.
Ok, gracias a postear mi code he aprendido mucho... ;D
Lo corregire en breves...
Una vez más:
Gracias BlackZeroX▓▓▒▒░░ :-* :xD