Animasi Partikel VB

Option Explicit

Type PARTICLE

X As Double 'x position
Y As Double 'y position
XMov As Double 'X axis Movement
YMov As Double 'Y axis Movement
XGrav As Double 'Gravitation x axis
YGrav As Double 'Gravitation y axis
LifeTime As Double 'lifetime

ySwitch As Boolean 'needed for ground detection

End Type

'This settings can be modified during runtime by sliders etc.
Public STOPvar As Boolean 'if set to true our animation stops
Public ANIMATIONvar As Boolean 'should the animation be activated ?
Public XPos As Double 'the orign (x)
Public YPos As Double 'the orign (y)
Public Power As Double 'energy
Public XGrav As Double 'Gravity x axis
Public YGrav As Double 'Gravity y axis
Public GroundCol As Boolean 'do particles change their direction when they touch the ground ?
Public ParticleType As Integer 'what kind of particles should be used ?
Public ParticleNum As Integer 'how many particles are used ?

Public Particles(999) As PARTICLE 'array of particles

'picturebox settings
Public Sub PrepareOutBox(OutBox As PictureBox)

OutBox.ScaleMode = 3 'set scalemode to pixel
OutBox.FillStyle = 0 'painted objects are filled solid

End Sub

'Draws a single particle into a picturebox
Public Sub DrawParticle(OutBox As PictureBox, XPos As Double, YPos As Double, Size As Integer, Colorsteps As Integer, Power As Double)

Dim looop As Integer
Dim iGrey As Integer
Dim iSteps As Integer
Dim iColorDiff As Integer
Dim iStepWidth As Integer

iSteps = Colorsteps 'how many rings are used to draw one particle ?
iColorDiff = Int(200 / iSteps) 'colordifference between two steps
iStepWidth = Size / iSteps 'how many pixels is one 'ring' thig ?

For looop = 0 To (iSteps - 1)

iGrey = Int((Power / 100) * (255 - iSteps * iColorDiff + looop * iColorDiff))
OutBox.FillColor = RGB(iGrey, iGrey, iGrey)
OutBox.Circle (XPos, OutBox.ScaleHeight - YPos), iSteps * iStepWidth - looop * iStepWidth, RGB(iGrey, iGrey, iGrey)

Next looop

End Sub

Public Sub DrawParticleAlternative(OutBox As PictureBox, XPos As Double, YPos As Double, Power As Double)

Dim iGrey As Integer

iGrey = Int((Power / 100) * 255)
OutBox.PSet (XPos, OutBox.ScaleHeight - YPos), RGB(iGrey, iGrey, iGrey)

End Sub


'setting each particles startingpoint, movement ...
Public Sub CreateParticles(OutBox As PictureBox)

Randomize Timer

Dim i As Integer

For i = 1 To ParticleNum

Particles(i).X = XPos
Particles(i).Y = YPos
Particles(i).XMov = -Power + Round(Rnd * 2 * Power, 2)
Particles(i).YMov = -Power + Round(Rnd * 2 * Power, 2)
Particles(i).LifeTime = 70 - Int(Rnd * 69)

Next i

End Sub

'central function
Public Sub Animation(OutBox As PictureBox)

Randomize Timer

Dim i As Integer 'loop variable

STOPvar = False
CreateParticles OutBox

'main loop
Do

OutBox.Cls 'clearing the picturebox for the next frame

For i = 1 To ParticleNum

'draw one particle
If ParticleType = 1 Then
DrawParticleAlternative OutBox, Particles(i).X, Particles(i).Y, Particles(i).LifeTime
ElseIf ParticleType = 2 Then
DrawParticle OutBox, Particles(i).X, Particles(i).Y, 5, 4, Particles(i).LifeTime
End If

Particles(i).X = Particles(i).X + Particles(i).XMov 'apply movement to current particle
Particles(i).X = Particles(i).X + Particles(i).XGrav 'apply gravitation

Particles(i).XGrav = Particles(i).XGrav + XGrav 'increase gravitation strength (x)

'hitting the ground or not ?
If Particles(i).ySwitch = False Then

Particles(i).Y = Particles(i).Y + Particles(i).YMov 'apply movement to current particle
Particles(i).Y = Particles(i).Y + Particles(i).YGrav 'apply gravitation

Particles(i).YGrav = Particles(i).YGrav + YGrav 'increase gravitation strength (y)

Else

Particles(i).Y = Particles(i).Y - Particles(i).YMov 'apply movement to current particle
Particles(i).Y = Particles(i).Y - Particles(i).YGrav 'apply gravitation

Particles(i).YGrav = Particles(i).YGrav - YGrav * 1.5 'decrease gravitation strength (y)

End If

'particle did hit the ground -> upward movement next time
If Particles(i).Y < 0 And GroundCol = True Then Particles(i).ySwitch = True


If Particles(i).LifeTime > 0 Then

Particles(i).LifeTime = Particles(i).LifeTime - 0.5

Else 'particle died and is reseted to the orign

Particles(i).X = XPos
Particles(i).Y = YPos
Particles(i).XMov = -Power + Round(Rnd * 2 * Power, 2)
Particles(i).YMov = -Power + Round(Rnd * 2 * Power, 2)
Particles(i).XGrav = 0
Particles(i).YGrav = 0
Particles(i).LifeTime = 100 - Int(Rnd * 30)
Particles(i).ySwitch = False

End If

Next i

'just 4 fun little animation
If ANIMATIONvar = True Then

Dim Message As String
Message = "Kuliah??? BSI AJAH ^.^"
XPos = Int(OutBox.ScaleWidth / 2) + Cos(Timer) * 200
YPos = Int(OutBox.ScaleHeight / 2) + Sin(Timer) * 100
OutBox.FontName = "Courier New"
OutBox.FontSize = 15
OutBox.CurrentX = Int(OutBox.ScaleWidth / 2) - 12 * (Len(Message) / 2)
OutBox.CurrentY = Int(OutBox.ScaleHeight / 2)
OutBox.ForeColor = RGB(70 + Int(Sqr(Cos(Timer * 2) * Cos(Timer * 2)) * 185), 70 + Int(Sqr(Sin(Timer * 2) * Sin(Timer * 2)) * 185), 70 + Int(Sqr(Sin(Timer) * Sin(Timer)) * 185))

Dim j As Integer

For j = 1 To Len(Message)

OutBox.CurrentX = Int(OutBox.ScaleWidth / 2) - 12.6 * (Len(Message) / 2) + j * 12 + Cos(Timer * 3) * 15
OutBox.CurrentY = Int(OutBox.ScaleHeight / 2) + Sin(j / 2) * Sin(Timer * 5) * 15 + Sin(Timer * 3) * 15
OutBox.Print Mid(Message, j, 1)

Next j

End If

DoEvents

Loop Until STOPvar = True

End Sub

****************************************************************************************
' Procedure :
' Author : Indrawan
' Date : 09/05/2011
' Purpose : prjParticle
' Blog : indrawan21.blogspot.com
'****************************************************************************************
'
Option Explicit
'Making it going All particle system code inside modParticle
Private Sub cmdStart_Click()

frmParticles.Enabled = False
optType1.Enabled = False
optType2.Enabled = False
lblPNum.Enabled = False
txtPNum.Enabled = False
Animation OUTPUT

End Sub

'Stop the animation
Private Sub cmdStop_Click()

STOPvar = True
frmParticles.Enabled = True
optType1.Enabled = True
optType2.Enabled = True
lblPNum.Enabled = True
txtPNum.Enabled = True

End Sub

'Some basic settings (orign, gravity ...) can be changed by sliders ...
Private Sub Form_Activate()

XPos = Int(OUTPUT.ScaleWidth / 2)
YPos = Int(OUTPUT.ScaleHeight / 2)
Power = 0.5
XGrav = 0
YGrav = 0
GroundCol = False
ParticleType = 1
ParticleNum = 300
ANIMATIONvar = True

End Sub

'stopt the animation before unloading
Private Sub Form_Unload(Cancel As Integer)

STOPvar = True
End

End Sub

'use small particles
Private Sub optType1_Click()

If optType1.Value = True Then
ParticleType = 1
ParticleNum = 300
txtPNum.Text = 300
End If


End Sub

'use ball particles
Private Sub optType2_Click()

If optType2.Value = True Then
ParticleType = 2
ParticleNum = 50
txtPNum = 50
End If

End Sub

'set a new orign via mouse input
Private Sub OUTPUT_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

XPos = X
YPos = OUTPUT.ScaleHeight - Y

End Sub

'Refresh Mouspointer Position, When Shift is pressed move the orign
Private Sub OUTPUT_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

lblPointer.Caption = "Position ( " & X & " / " & Y & " )"

If Shift = 1 Then
XPos = X
YPos = OUTPUT.ScaleHeight - Y
End If

End Sub

'change x gravity via slider control
Private Sub slGravX_Change()

XGrav = slGravX / 20

End Sub

'change y gravity via slider control
Private Sub slGravY_Change()

YGrav = slGravY / 20

End Sub

'strength of the effect
Private Sub slPower_Change()

Power = slPower.Value / 5

End Sub

'check if the input is a number
Private Sub txtPNum_KeyPress(KeyAscii As Integer)

If InStr("0123456789", Chr(KeyAscii)) = False And KeyAscii <> 8 Then KeyAscii = 0

End Sub

'if checked particles hit the ground and jump up again
Private Sub chkGround_Click()

GroundCol = chkGround.Value

End Sub

'set new particle number
Private Sub txtPNum_KeyUp(KeyCode As Integer, Shift As Integer)

If txtPNum.Text = "" Then ParticleNum = 0 Else ParticleNum = txtPNum.Text

End Sub

'Enable the Animation
Private Sub chkAnimation_Click()

If chkAnimation.Value = 1 Then
ANIMATIONvar = True
Else
ANIMATIONvar = False
End If

End Sub