VERSION 5.00 Begin VB.Form Form1 AutoRedraw = -1 'True BorderStyle = 0 'None Caption = "Particles System Demo" ClientHeight = 4815 ClientLeft = 0 ClientTop = 0 ClientWidth = 6705 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 321 ScaleMode = 3 'Pixel ScaleWidth = 447 ShowInTaskbar = 0 'False StartUpPosition = 2 'CenterScreen Begin VB.PictureBox picWindBack BackColor = &H00000000& Height = 315 Left = 120 ScaleHeight = 17 ScaleMode = 3 'Pixel ScaleWidth = 101 TabIndex = 3 Top = 120 Width = 1575 Begin VB.PictureBox picWind BackColor = &H00404040& BorderStyle = 0 'None Height = 225 Left = 660 ScaleHeight = 15 ScaleMode = 3 'Pixel ScaleWidth = 50 TabIndex = 5 Top = 15 Width = 750 End Begin VB.Label lblWind BackColor = &H00000000& Caption = "Wind" ForeColor = &H00808080& Height = 255 Left = 120 TabIndex = 4 Top = 30 Width = 375 End End Begin VB.PictureBox picBackgroundImage AutoSize = -1 'True BackColor = &H00000000& BorderStyle = 0 'None Height = 375 Left = 3960 ScaleHeight = 25 ScaleMode = 3 'Pixel ScaleWidth = 23 TabIndex = 2 Top = 2280 Visible = 0 'False Width = 345 End Begin VB.PictureBox picBack AutoSize = -1 'True BackColor = &H00000000& BorderStyle = 0 'None Height = 4815 Left = 2760 ScaleHeight = 321 ScaleMode = 3 'Pixel ScaleWidth = 447 TabIndex = 0 Top = 2880 Visible = 0 'False Width = 6705 End Begin VB.PictureBox picFront AutoSize = -1 'True BackColor = &H00404040& BorderStyle = 0 'None Height = 4815 Left = 0 ScaleHeight = 321 ScaleMode = 3 'Pixel ScaleWidth = 447 TabIndex = 1 Top = 0 Width = 6705 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Option Explicit Option Base 1 'This is so the arrays are 1-based 'Declare the API functions (DrawPixelV, GetPixel, GetTickCount and 'BitBlt) Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, _ ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, _ ByVal X As Long, ByVal Y As Long) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long Private Declare Function BitBlt Lib "gdi32" ( _ ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _ ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long 'This is the type that defines one of our particles... Private Type tParticle 'Position X As Single Y As Single 'Horizontal/vertical speed SpeedX As Single SpeedY As Single 'State (0 = Moving down; 1 = Fading away [touched the ground]) State As Byte 'Colors ColorR As Byte ColorG As Byte ColorB As Byte End Type 'This array holds all of our particles Dim Particles() As tParticle 'The number of particles in the array (this is so we don't have to 'use UBound all the time) Dim NumParticles As Long 'The number of active particles. This is used so that not all the 'particles are active at first. The number starts at 0 and is 'increased each frame. Only these particles are moved and drawn '(the ones which have an index <= this number) 'NOTE: It's a Single so that we can increase it by a number smaller 'than 1, eg.: if you increase it 0.1 every frame, you'll get one 'more active particle every 10 frames :) Dim ActiveParticles As Single 'This is True while the loop is running (it's for the "game engine", 'you should have something similar in your game loop so it's not 'important for the particles system itself) Dim Running As Boolean 'This is used to slow down the FPS (so it doesn't run too fast) Dim LastTick As Long 'A temporary loop counter Dim i As Long 'The wind speed Dim WindSpeed As Single 'The speed of the rain Private Const SpeedMultiplier As Single = 6 Private Sub Form_Load() 'Load the background image Me.Move 0, 0, Screen.Width, Screen.Height keybd_event vbKeySnapshot, 1, 0&, 0& picBackgroundImage.Picture = Clipboard.GetData picBackgroundImage.Refresh picFront.Width = Me.Width picFront.Height = Me.Height picBack.Height = Me.Height picBack.Width = Me.Width 'Generate new random numbers Randomize Timer 'First we'll have to initialize all the particles... 'Resize the array NumParticles = 150 ReDim Particles(NumParticles) 'Loop trough all of the particles... For i = 1 To NumParticles With Particles(i) 'This will center this particle on the screen .X = Rnd * picBack.Width .Y = -2 'Set the horizontal/vertical speed .SpeedY = 1 + Rnd 'A number between 1 and 2 'Set the color to a random shade of a very bright and pale 'blue... Part of the color is multiplied by the vertical 'speed, so the greater the vertical speed is, the brighter 'the particle is :) .ColorB = 98 + 40 * .SpeedY .ColorG = 72 + 40 * .SpeedY .ColorR = 31 + 40 * .SpeedY 'Now, multiply the speed by the speed multiplier to get 'the real speed (for the values I used for the colors, the 'speed MUST NOT be greater than 2, so we can't multiply it 'earlier) .SpeedY = .SpeedY * SpeedMultiplier End With Next i 'Make sure everything's initialized Me.Show DoEvents 'This is the main loop! Running = True Do While Running 'Slow down the FPS... Do DoEvents Loop Until GetTickCount() >= LastTick + 30 LastTick = GetTickCount() 'Draw the background image into the backbuffer BitBlt picBack.hdc, 0, 0, picFront.Width, picFront.Height, _ picBackgroundImage.hdc, 0, 0, vbSrcCopy 'Run the particles system! RunParticles 'Flip the backbuffer (show what we've drawn) BitBlt picFront, 0, 0, picFront.Width, picFront.Height, _ picBack.hdc, 0, 0, vbSrcCopy Loop End Sub Private Sub Form_Unload(Cancel As Integer) 'Terminate the loop and exit Running = False DoEvents End End Sub Private Sub picFront_Click() End End Sub 'NOTE: The following 3 subs are just for the wind bar - they're not 'part of the actual particles system :) Private Sub picWind_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'Run the code for a MouseMove event picWind_MouseMove Button, Shift, X, Y End Sub Private Sub picWind_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'If the user is clicking... If Button = vbLeftButton Then 'Set the wind speed based on the position of the bar WindSpeed = X / 5 - 5 If WindSpeed < -5 Then WindSpeed = -5 If WindSpeed > 5 Then WindSpeed = 5 'Redraw it picWind_Paint End If End Sub Private Sub picWind_Paint() 'Clear the picturebox picWind.Cls 'Draw the light gray box picWind.Line (0, 0)-(picWind.Width - 1, picWind.Height - 1), RGB(128, 128, 128), B 'Draw the position of the "bar" picWind.Line (WindSpeed * 5 + 25, 0)-(WindSpeed * 5 + 25, picWind.Height), RGB(128, 128, 128) End Sub Private Sub RunParticles() Dim tR As Byte, tG As Byte, tB As Byte, tempcheck As Byte Dim j As Long 'Increase the number of active particles... If ActiveParticles < NumParticles Then ActiveParticles = ActiveParticles + Rnd If ActiveParticles > NumParticles Then ActiveParticles = NumParticles End If 'Loop trough all of the particles... For i = 1 To ActiveParticles With Particles(i) 'Move this particle according to its speed .X = .X + WindSpeed .Y = .Y + .SpeedY 'Check if it has reached the left/right edges of the screen, 'in that case move it to the other edge... If .X < 0 Then .X = .X + picBack.Width If .X > picBack.Width Then .X = .X - picBack.Width 'Check if it has reached the bottom... If .Y >= picBack.Height Then 'Move it back to the top again .X = Rnd * picBack.Width .Y = -2 End If If .State = 0 Then 'If it's falling... 'This will make the particles randomly touch the 'ground sometimes (we set the state to 1 so that 'from now on they'll fade) If Rnd < 0.002 Then .State = 1 Else 'If it's fading... 'Slowly fade the particle to black... .ColorR = .ColorR - 1 .ColorG = .ColorG - 1 .ColorB = .ColorB - 1 'Check if it stopped fading (it's almost black)... If .ColorR < 32 Then 'Move it back to the top again .X = Rnd * picBack.Width .Y = -2 'Set the state so it doesn't fade anymore .State = 0 'Set the speed again (between 1 and 2) .SpeedY = 1 + Rnd 'Set the color again... .ColorB = 98 + 40 * .SpeedY .ColorG = 72 + 40 * .SpeedY .ColorR = 31 + 40 * .SpeedY 'Multiply it by the speed multiplier .SpeedY = .SpeedY * SpeedMultiplier End If End If 'Draw it as a vertical line, according to the speed '(the greater the speed, the longer the line is) For j = 0 To .SpeedY \ 4 DrawPixel .X, .Y + j, .ColorR, .ColorG, .ColorB Next j End With Next i End Sub 'This function draws a pixel using a special effect Private Sub DrawPixel(ByVal X As Long, ByVal Y As Long, _ ByVal R1 As Byte, ByVal G1 As Byte, ByVal B1 As Byte) Dim TempColor As Long Dim R2 As Long, G2 As Long, B2 As Long 'Get the color of the original pixel TempColor = GetPixel(picBack.hdc, X, Y) 'Extract each one of the RGB values of the original pixel '(don't waste your time trying to understand it :) ) R2 = TempColor And 255 G2 = (TempColor And 65535) \ 256 B2 = (TempColor And 16777215) \ 65536 'Add the original RGB values to the particle's RGB values R2 = R2 + R1 G2 = G2 + G1 B2 = B2 + B1 'Check if they're not above 255 If R2 > 255 Then R2 = 255 If G2 > 255 Then G2 = 255 If B2 > 255 Then B2 = 255 'Draw the pixel SetPixelV picBack.hdc, X, Y, RGB(R2, G2, B2) End Sub