Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Option Explicit
Option Base 1 'This is so the arrays are 1-based
Private Const SRCCOPY = &HCC0020
'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
picBackgroundImage.Move 0, 0, Me.Width, Me.Height
picBack.Move 0, 0, Me.Width, Me.Height
picBackgroundImage.Picture = LoadPicture(App.Path & "\background.bmp")
'Generate new random numbers
Randomize Timer
SystemParametersInfo 97, True, CStr(0), 0
'First we'll have to initialize all the particles...
'Resize the array
NumParticles = 200000
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, picBack.Width, picBack.Height, _
picBackgroundImage.hdc, 0, 0, SRCCOPY
'Run the particles system!
RunParticles
Loop
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Terminate the loop and exit
Running = False
DoEvents
End
End Sub
Private Sub picBack_Click()
Dim RealPassword, Password As String
RealPassword = GetSetting("ScreenSaver", "settings", "password", "")
Password = InputBox("Enter Password:", "Password")
If Password = RealPassword Then
SystemParametersInfo 97, False, CStr(0), 0
End
End If
End Sub
Private Sub picBackgroundImage_Paint()
picBackgroundImage.Picture = LoadPicture(App.Path & "\collybia.bmp")
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
