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
Código
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!