ENFIN DE LA NEIGE QUI S'ACCUMULE VRAIMENT !

'Par Setaou
'http://setaou.ctw.cc

Private Type Floc
X As Integer
Y As Integer
End Type
Dim Flocon() As Floc, Maxi As Integer, Tas() As Long

Private Sub Form_Click()
Timer1.Enabled = Not Timer1.Enabled 'Arrête ou remet le timer
End Sub

Private Sub Form_Resize()
Form1.ScaleMode = 3
Form1.Cls 'Efface le form

Maxi = (Form1.Width + Form1.Height) / 100 ' Caclule le nombre max de flocons
ReDim Flocon(Maxi) 'Redimmentionne les tableaux
ReDim Tas(Form1.ScaleWidth)

For i = 1 To Maxi 'Place aléatoirement les flocons sur le form
Flocon(i).X = Int(Rnd * Form1.ScaleWidth + 1)
Flocon(i).Y = Int(Rnd * Form1.ScaleHeight + 1)
Next i
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
For i = 1 To Maxi

PSet (Flocon(i).X, Flocon(i).Y), Form1.BackColor 'Efface l'ancienne position du flocon

Flocon(i).Y = Flocon(i).Y + Int(Rnd * 10 + 1) ' Calcule la nouvelle position
Flocon(i).X = Flocon(i).X + Int(Rnd * 10 - 5)

If Flocon(i).X < 0 Then Flocon(i).X = Form1.ScaleWidth ' Si le flocon sort par la droite ou la gauche
If Flocon(i).X > Form1.ScaleWidth Then Flocon(i).X = 1

If Flocon(i).Y >= Form1.ScaleHeight - Tas(Flocon(i).X) Then 'si le flocon tombe sur le tas
Select Case Tas(Flocon(i).X)
Case Is > Tas(Flocon(i).X - 2): Tas(Flocon(i).X - 2) = Tas(Flocon(i).X - 2) + 1
Case Is > Tas(Flocon(i).X + 2): Tas(Flocon(i).X + 2) = Tas(Flocon(i).X + 2) + 1
Case Is > Tas(Flocon(i).X - 1): Tas(Flocon(i).X - 1) = Tas(Flocon(i).X - 1) + 1
Case Is > Tas(Flocon(i).X + 1): Tas(Flocon(i).X + 1) = Tas(Flocon(i).X + 1) + 1
Case Else: Tas(Flocon(i).X) = Tas(Flocon(i).X) + 1
End Select
Line (Flocon(i).X, Form1.ScaleHeight - Tas(Flocon(i).X))-(Flocon(i).X, Form1.ScaleHeight), vbWhite 'Dessine une partie du tas
Flocon(i).Y = 0 'Replace le flocon en haut
Flocon(i).X = Int(Rnd * Form1.ScaleWidth + 1)
End If

PSet (Flocon(i).X, Flocon(i).Y), vbWhite 'Affiche le flocon

Next i

For i = 1 To Form1.ScaleWidth
j = j + Tas(i)
Next i
j = j / Form1.ScaleWidth
Label1.Caption = Maxi & " Flocons de neige"
Label1.Caption = Label1.Caption & " - Epaisseur moyenne de la neige : " & Format(j, "0.000") & "px"
End Sub