[Source] Fireworks - Lanza petardos y cohetes en VB6

[Mad Antrax]

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"



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 (vb) [Seleccionar] Expandir

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!

[d(-_-)b]

Gracias ||MadAntrax|| Buen code,...Precioso..

Saludos...

[Red Mx]

Interesante , yo tengo algo parecido pero simula una lluvia de estrellas

[Karcrack]

Joder Mad, no paras .
Red Mx podrias postearlo? Gracias 

Karcrack

[3k1n0x]

jejeje esta muy bonito gracias x el code 

[Red Mx]

Joder Mad, no paras .
Red Mx podrias postearlo? Gracias 

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

[Nork]

Me gusto mucho el efecto, gracias!!

[Freeze.]

Mad buen code pero muy lento jejejeje eso hay q modificarlo...

RedMx Buen Code ese gusta bastante ajajajaja