Precioso efecto para añadir en nuestro "About Dialog Box" de cualquier aplicación. Lanza petardos y cohetes de forma aleatória y con colores. Utiliza AlphaBending para simular efecto de "petardo"
(http://img372.imageshack.us/img372/7052/fireworkshv0.jpg)
Ojo, el source no es mio, lo encontré en www.pscode.com como un screensaver, he tenido que modificar bastante el código para dejarlo limpio y listo para usarlo. Sencillamente precioso, no utiliza librerías de DX7 ni DLL''s ni OCX''s
Private Type Particle
X As Single
Y As Single
Xv As Single
Yv As Single
Life As Integer
Dead As Boolean
Color As Long
End Type
Private Type FireWork
X As Single
Y As Single
Height As Integer
Color As Long
Exploded As Boolean
P() As Particle
End Type
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hDC As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDC As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SetPixelV Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Dim BF As BLENDFUNCTION
Dim lBF As Long
Dim FW() As FireWork
Dim FWCount As Integer
Dim RocketSpeed As Integer
Private Sub StartFireWork()
For i = 0 To FWCount
If FW(i).Y = -1 Then
GoTo MAKEFIREWORK
End If
Next i
FWCount = FWCount + 1
ReDim Preserve FW(FWCount)
i = FWCount
MAKEFIREWORK:
FW(i).X = Int(Rnd * Me.ScaleWidth)
FW(i).Y = Me.ScaleHeight
FW(i).Height = Rnd * Me.ScaleHeight
FW(i).Color = Int(Rnd * vbWhite)
FW(i).Exploded = False
ReDim FW(i).P(10)
End Sub
Private Sub DrawFireWork(tFW As FireWork)
Dim DeadCount As Integer
Dim RndSpeed As Single
Dim RndDeg As Single
With tFW
If .Exploded Then
For i = 0 To UBound(.P)
If .P(i).Life > 0 Then
.P(i).Life = .P(i).Life - 1
.P(i).X = .P(i).X + .P(i).Xv
.P(i).Y = .P(i).Y + .P(i).Yv
.P(i).Xv = .P(i).Xv / 1.05
.P(i).Yv = .P(i).Yv / 1.05 + 0.05
PSet (.P(i).X, .P(i).Y), .P(i).Color
ElseIf .P(i).Life > -40 Then
.P(i).Life = .P(i).Life - 1
.P(i).X = .P(i).X + .P(i).Xv + (0.5 - Rnd)
.P(i).Y = .P(i).Y + .P(i).Yv + 0.1
.P(i).Xv = .P(i).Xv / 1.05
.P(i).Yv = .P(i).Yv
SetPixelV Me.hDC, .P(i).X, .P(i).Y, .P(i).Color
Else
.P(i).Dead = True
DeadCount = DeadCount + 1
End If
Next i
If DeadCount >= UBound(.P) Then
.Y = -1
End If
Else
.Y = .Y - RocketSpeed
If .Y < .Height Then
Dim ExplosionShape As Integer
ExplosionShape = Int(Rnd * 6)
Select Case ExplosionShape
Case 0 ''Regular
ReDim .P(Int(Rnd * 100) + 100)
For i = 0 To UBound(.P)
.P(i).X = .X
.P(i).Y = .Y
.P(i).Life = Int(Rnd * 20) + 20
RndSpeed = (Rnd * 5)
RndDeg = (Rnd * 360) / 57.3
.P(i).Xv = RndSpeed * Cos(RndDeg)
.P(i).Yv = RndSpeed * Sin(RndDeg)
.P(i).Color = .Color
Next i
.Exploded = True
Case 1 ''Smilely
ReDim .P(35)
ReDim .P(50)
ReDim .P(52)
For i = 0 To 35
.P(i).X = .X
.P(i).Y = .Y
.P(i).Life = 50
.P(i).Xv = 3 * Cos(((360 / 35) * (i + 1)) / 57.3)
.P(i).Yv = 3 * Sin(((360 / 35) * (i + 1)) / 57.3)
.P(i).Color = .Color
Next i
For i = 36 To 50
.P(i).X = .X
.P(i).Y = .Y
.P(i).Life = 50
.P(i).Xv = 2 * Cos(((360 / 35) * i + 15) / 57.3)
.P(i).Yv = 2 * Sin(((360 / 35) * i + 15) / 57.3)
.P(i).Color = .Color
Next i
With .P(51)
.X = tFW.X
.Y = tFW.Y
.Life = 50
.Xv = 2 * Cos(-55 / 57.3)
.Yv = 2 * Sin(-55 / 57.3)
.Color = tFW.Color
End With
With .P(52)
.X = tFW.X
.Y = tFW.Y
.Life = 50
.Xv = 2 * Cos(-125 / 57.3)
.Yv = 2 * Sin(-125 / 57.3)
.Color = tFW.Color
End With
.Exploded = True
Case 2 ''Star
ReDim .P(50)
RndDeg = Int(360 * Rnd)
For i = 0 To UBound(.P)
.P(i).X = .X
.P(i).Y = .Y
.P(i).Life = 50
.P(i).Xv = (i * 0.1) * Cos(((360 / 5) * (i + 1) + RndDeg) / 57.3)
.P(i).Yv = (i * 0.1) * Sin(((360 / 5) * (i + 1) + RndDeg) / 57.3)
.P(i).Color = .Color
Next i
.Exploded = True
Case 3 ''Spiral
ReDim .P(50)
RndDeg = (360 * Rnd)
For i = 0 To UBound(.P)
.P(i).X = .X
.P(i).Y = .Y
.P(i).Life = 50
.P(i).Xv = (i * 0.1) * Cos(((360 / 25) * (i + 1) + RndDeg) / 57.3)
.P(i).Yv = (i * 0.1) * Sin(((360 / 25) * (i + 1) + RndDeg) / 57.3)
.P(i).Color = .Color
Next i
.Exploded = True
Case 4 ''Regular Random
ReDim .P(Int(Rnd * 100) + 100)
For i = 0 To UBound(.P)
.P(i).X = .X
.P(i).Y = .Y
.P(i).Life = Int(Rnd * 20) + 20
RndSpeed = (Rnd * 5)
RndDeg = (Rnd * 360) / 57.3
.P(i).Xv = RndSpeed * Cos(RndDeg)
.P(i).Yv = RndSpeed * Sin(RndDeg)
.P(i).Color = Int(Rnd * vbWhite)
Next i
.Exploded = True
End Select
Else
SetPixelV Me.hDC, .X, .Y, vbWhite
End If
End If
End With
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
End
End Sub
Private Sub Form_Load()
Randomize
RocketSpeed = Int(Rnd * 4) + 2
FWCount = -1
BF.BlendOp = &H0
BF.BlendFlags = 0
BF.AlphaFormat = 0
End Sub
Private Sub Timer1_Timer()
For i = 0 To FWCount
DrawFireWork FW(i)
Next i
RtlMoveMemory lBF, BF, 4
AlphaBlend Me.hDC, 0, 0, Me.ScaleWidth, Me.ScaleHeight, Picture1.hDC, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, lBF
Me.Refresh
End Sub
Private Sub Timer2_Timer()
StartFireWork
BF.SourceConstantAlpha = Int(Rnd * 25)
Timer2.Interval = Int(Rnd * 500)
Label1.ForeColor = FW(i).Color
End Sub
Download only for registered users!
Gracias ||MadAntrax|| Buen code,...Precioso..
Saludos...
Interesante , yo tengo algo parecido pero simula una lluvia de estrellas
Joder Mad, no paras :P.
Red Mx podrias postearlo? Gracias ;D
Karcrack
jejeje esta muy bonito gracias x el code ;D
Cita de: Karcrack en 15 Julio 2007, 19:56 PM
Joder Mad, no paras :P.
Red Mx podrias postearlo? Gracias ;D
Karcrack
Claro aqui esta cabe señalar que el code no es mio pero no esta dificil
http://mx.geocities.com/winrar_center/lluviaestrellas.zip
Me gusto mucho el efecto, gracias!!
Mad buen code pero muy lento jejejeje eso hay q modificarlo...
RedMx Buen Code ese gusta bastante ajajajaja