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