Bonne Année!

Merci pour ce très beau feu d'artifice François !

Un conseil : d'abors lancer VB puis copier-coller le code.
Je ne sais pas ce que fait VB au démarrage, mais il vire le contenu du
presse-papier...

Bonne année à toutes et à tous. Que VB6 vous apporte encore beaucoup de
bonheur et de découvertes.

Guy DETIENNE

"Picalausa François" <fpicalausa@chez.com> a écrit dans le message de
news:u9iaKvlDGHA.344@TK2MSFTNGP11.phx.gbl...

Hello,

Bonne année, avec plus ou moins d'heures d'avance/de retard en fonction de
la timezone à tous!
Que VB soit avec vous, ainsi que l'argent, le succès, et tout ce que vous
souhaitez pour 2006.

Voici un bout de code, à copier coller dans une form contenant une
picturebox, pctBackBuffer, pour voir ces voeux en couleur:
Option Explicit

Private Const TimePerYear As Single = 0.002 'Temps entre l'update de
chaque année
Private Const Yinc As Long = 6 'Incrément utilisé entre
deux calculs
Private Const MinTimePerGlitch As Single = 2 'Temps minimum pour le
retour en arrière
Private Const MinTimePerGlitchRndPart As Single = 4 'Modification sur cd
temps minimum
Private Const YStop As Long = 2006 'L'année!
Private Const YGlitchStop As Long = 1000 'L'année de retour

minimale

Private Const ConsumptionRate As Single = 0.2 'vitesse à laquelle

diminue

la particule
'(w = w0 - w0 *
ConsumptionRate * (t - t0))
Private Const Pi As Single = 3.14159265 'pi, pas le g!

Private Const PARTICLES_COUNT = 150 'nombre de particules par
feu d'artifice
Private Const PARTICLE_MAX_OWN_SPD = 1050 'Vitesse max propre à une
particule (répartie entre x et y)
Private Const PARTICLE_MAX_SIZE = 78 'Taille maximale de la
particule
Private Const PARTICLE_MIN_SIZE = 3 'Taille minimale de la
particule
Private Const PGROUP_V0X_MAX = 750 'Vitesse max de la fusée

en

X, lors de l'explosion
Private Const PGROUP_V0Y_MAX = 1000 'Vitesse max de la fusée

en

Y, lors de l'explosion

Private Const PARTICLES_MAX_SPD = 150 'nombre de particules par
feu d'artifice
Private Const MAX_GROUPS = 5 'maximum de feux

d'artifices

en même temps à l'écran
Private Const STARS_PER_2250000_SQTWIPS = 5 'Nombre d'étoiles par
2250000 twips ² (100x100 pixels en général)

'Définition d'un vecteur
Private Type VECT
X As Single
Y As Single
End Type

'Définition composante/composante d'une couleur (ici, ARGB)
Private Type ARGBColor
Alpha As Byte
R As Byte
G As Byte
B As Byte
End Type

'Un fond étoilé?
Private Type STAR
X As VECT
W As Single
Color As ARGBColor
End Type

'Définition d'une particule de feu d'artifice
Private Type PARTICLE
w0 As Single 'dimension initiale
Color As ARGBColor 'couleur de la particule
V0 As VECT 'vitesse initiale
t0 As Single 'première apparition
x0 As VECT 'position initiale
End Type

Private Type ParticleGroup
Particles(1 To PARTICLES_COUNT) As PARTICLE 'Chaque particule
composant le feu d'artifice
Alive As Boolean 'Y a-t-il encore des
particules en vie?
End Type

Private mColorTimeStart As Single 'Temps de début de la
transition
Private mColorTimeEnd As Single 'Temps de fin de la
transition
Private mBaseColor As ARGBColor 'Couleur de laquelle

on

part
Private mEndColor As ARGBColor 'Couleur à laquelle on
arrive
Private mCurrentYear As Long 'Compteur pour le
défilement des années
Private mbRunning As Long 'Le programme tourne?
Private PGroups(1 To MAX_GROUPS) As ParticleGroup 'Feux d'artifice en
cours
Private Stars() As STAR 'Etoiles dans

l'univers

Private mbRenderStars As Boolean 'Effectuer le rendu
des étoiles (touche s)
Private mbRenderFW As Boolean 'Effectuer le rendu
des feux d'artifice (touche f)


'Détermine une couleur pseudo aléatoire
Private Function RandomColor() As ARGBColor
RandomColor.R = Rnd * 255
RandomColor.G = Rnd * 255
RandomColor.B = Rnd * 255
End Function

'Détermine une couleur jaune pseudo aléatoire
Private Function RandomYellowColor() As ARGBColor
Dim BaseColor As Byte, LessBlue As Byte

'Décallage vers le jaune
LessBlue = Rnd * 32

'Couleur en niveau de gris
BaseColor = 255 - Rnd * 128

RandomYellowColor.R = BaseColor
RandomYellowColor.G = BaseColor
RandomYellowColor.B = BaseColor - LessBlue
End Function

'Effectue une interpolation linéaire entre deux couleurs compos/compos
Private Function Interpolate( _
Color1 As ARGBColor, _
Color2 As ARGBColor, _
Frame As Single) As ARGBColor

'Ne devrait pas se produire... juste au cas où!
If Frame < 0 Then Frame = 0
If Frame > 1 Then Frame = 1

Interpolate.R = Color1.R + (CSng(Color2.R) - Color1.R) * Frame
Interpolate.G = Color1.G + (CSng(Color2.G) - Color1.G) * Frame
Interpolate.B = Color1.B + (CSng(Color2.B) - Color1.B) * Frame
End Function

'Trace les étoiles sur le fond pour réutilisation intensive
Private Sub RenderStars()
Dim i As Long

pctBackBuffer.Cls
Set pctBackBuffer.Picture = Nothing
pctBackBuffer.DrawStyle = 5 'transparent
pctBackBuffer.FillStyle = 0 'Solid

If mbRenderStars Then
'trace le fond étoilé
For i = 0 To UBound(Stars)
pctBackBuffer.FillColor = GetRGB(Stars(i).Color)
pctBackBuffer.Circle (Stars(i).X.X, Stars(i).X.Y), Stars(i).W
Next i
End If

Set pctBackBuffer.Picture = pctBackBuffer.Image

pctBackBuffer.DrawStyle = 0 'solid
pctBackBuffer.FillStyle = 1 'transparent
End Sub

'Effectue le tracé des données
Private Sub Render()
Dim Color As ARGBColor, strYear As String, BlackColor As ARGBColor
Dim i As Long, j As Long
Dim Position As VECT, LifeTime As Single, Spd As VECT

Const Text1 As String = " Megabytes of free memory"
Const Text2 As String = "Happy new year!"

'Efface les données précédentes
pctBackBuffer.Cls

'Calcule la nouvelle couleur
If (mColorTimeEnd - mColorTimeStart) <> 0 Then
Color = Interpolate(mBaseColor, mEndColor, (Timer -

mColorTimeStart)

/ (mColorTimeEnd - mColorTimeStart))
End If
pctBackBuffer.ForeColor = GetRGB(Color)

'Détermine la première partie du texte à afficher
strYear = Format(mCurrentYear, "0000") & Text1

'Affiche la première partie du texte
pctBackBuffer.CurrentX = (pctBackBuffer.ScaleWidth -
pctBackBuffer.TextWidth(strYear)) / 2
pctBackBuffer.CurrentY = (pctBackBuffer.ScaleHeight -
pctBackBuffer.TextHeight(strYear & vbCrLf)) / 2
pctBackBuffer.Print strYear

'Seulle la nouvelle année est spéciale
If mCurrentYear = YStop Then
pctBackBuffer.CurrentX = (pctBackBuffer.ScaleWidth -
pctBackBuffer.TextWidth(Text2)) / 2
pctBackBuffer.CurrentY = (pctBackBuffer.ScaleHeight -
pctBackBuffer.TextHeight(strYear & vbCrLf)) / 2 +
pctBackBuffer.TextHeight(strYear & vbCrLf) - Me.TextHeight(Text2)
pctBackBuffer.Print Text2
End If


'Trace les feu d'artifice en cours
pctBackBuffer.DrawStyle = 5 'transparent
pctBackBuffer.FillStyle = 0 'Solid

If mbRenderFW Then
For j = 1 To MAX_GROUPS
If PGroups(j).Alive Then
PGroups(j).Alive = False
For i = 1 To PARTICLES_COUNT
With PGroups(j).Particles(i)
'Age de la particule
LifeTime = (Timer - .t0)

If .w0 - ConsumptionRate * .w0 * LifeTime > 0 Then
PGroups(j).Alive = True

'Calcule les nouvelles vitesses
Spd.X = .V0.X
Spd.Y = (LifeTime * 200 + .V0.Y) 'supposé

indép

du poids

'Calcule la position de la particule
Position.X = .x0.X + Spd.X * LifeTime
Position.Y = .x0.Y + Spd.Y * LifeTime

'Trace la particule
pctBackBuffer.FillColor > GetRGB(Interpolate(.Color, BlackColor, LifeTime * ConsumptionRate))
pctBackBuffer.Circle (Position.X, Position.Y),
.w0 - ConsumptionRate * .w0 * LifeTime
End If
End With
Next i
End If
Next j
End If

pctBackBuffer.DrawStyle = 0 'solid
pctBackBuffer.FillStyle = 1 'transparent

End Sub

'Retourne la couleur vb à partir d'une structure ARGBColor
Private Function GetRGB(Color As ARGBColor) As Long
GetRGB = RGB(Color.R, Color.G, Color.B)
End Function

'Affiche le tracé à l'écran
Private Sub Present()
Set Me.Picture = pctBackBuffer.Image
End Sub

Private Sub Form_Click()
mbRunning = False
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyS
mbRenderStars = Not mbRenderStars
RenderStars
Case vbKeyF
mbRenderFW = Not mbRenderFW
End Select
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
mbRunning = False
End Sub

Private Sub GenStars()
Dim i As Long
Dim Surface As Long
Dim StarsCount As Long

'Compte le nombre d'étoiles à la surface de l'univers
Surface = Me.ScaleWidth * Me.ScaleHeight / 2250000
StarsCount = Surface * STARS_PER_2250000_SQTWIPS

'Réserve de l'espace galactique pour étoiles
If StarsCount = 0 Then
ReDim Stars(-1 To -1)
Else
ReDim Stars(0 To StarsCount - 1)
End If

'Initialise la galaxie
For i = 0 To UBound(Stars)
'Définit une couleur claire
Stars(i).Color = RandomYellowColor

'Chaque étoile à sa propre taille
Stars(i).W = Rnd * 19 + 3

'La galaxie se limitera à al partie visible de l'écran
Stars(i).X.X = Rnd * Me.ScaleWidth
Stars(i).X.Y = Rnd * Me.ScaleHeight
Next i

RenderStars
End Sub

Private Sub Form_Load()
Dim LastYearTick As Single, TimeToNextGlitch As Single

'Initialise diverses propriétés
pctBackBuffer.FontSize = 15
pctBackBuffer.BorderStyle = 0
pctBackBuffer.AutoRedraw = True
pctBackBuffer.Visible = False

'Par défaut on suppose qu'on a une bonne machine
mbRenderStars = True
mbRenderFW = True

'C'est plus joli la nuit
pctBackBuffer.BackColor = vbBlack
GenStars

'Génère la couleur de *départ*
mEndColor = RandomColor

'Précalcule le temps de l'erreur suivante
TimeToNextGlitch = MinTimePerGlitch + MinTimePerGlitchRndPart * Rnd

'Avec affichage c'est mieux
Me.Show
'Et si l'affichage change à chaque fois c'est encore mieux
Randomize Timer

'Fait tourner le programme
mbRunning = True

While (mbRunning)
'Incrémente les années, tant qu'il y en a a passer
If Timer - LastYearTick > TimePerYear And mCurrentYear < YStop

Then

mCurrentYear = mCurrentYear + Yinc
If mCurrentYear > YStop Then mCurrentYear = YStop
LastYearTick = Timer
End If

'Déja finit de compter? revient de temps à autres en arrière
If mCurrentYear = YStop And Timer - LastYearTick >

TimeToNextGlitch

Then
TimeToNextGlitch = MinTimePerGlitch + MinTimePerGlitchRndPart

*

Rnd
mCurrentYear = YStop - Rnd * (YStop - YGlitchStop)
LastYearTick = Timer
End If

'Vérifie si on doit calculer une nouvelle transition de couleurs
If mColorTimeEnd < Timer Then
mColorTimeStart = Timer
mColorTimeEnd = Timer + 1 + Rnd * 2
mBaseColor = mEndColor
mEndColor = RandomColor

GetFireworks Rnd * Me.ScaleWidth, Rnd * Me.ScaleHeight,
mEndColor
End If

'Trace les données à jour
Render
'Les affiche à l'écran
Present
'Il faut respirer
DoEvents
Wend

'On sort... à la fin
Unload Me
End Sub

'Génère un feu d'artifice prêt à l'emploi
Private Function GetFireworks(X As Single, Y As Single, Color As

ARGBColor)

As Long
Dim i As Long, Norm As Single, Theta As Single, V0 As VECT

'Trouve le groupe qui sera utilisé
For GetFireworks = 1 To MAX_GROUPS
If PGroups(GetFireworks).Alive = False Then
Exit For
End If
Next

'Y a-t-il encore des groupes disponibles?
If GetFireworks < MAX_GROUPS + 1 Then
'Définit une vitesse de montée initiale
V0.Y = Rnd * PGROUP_V0Y_MAX
V0.X = Rnd * PGROUP_V0X_MAX * 2 - PGROUP_V0X_MAX

'Initialise chaque particule
For i = 1 To PARTICLES_COUNT
With PGroups(GetFireworks).Particles(i)
'Couleur et temps de création, position initiale
.Color = Color
.t0 = Timer
.x0.X = X
.x0.Y = Y

'Norme et direction de la modification au vecteur vitesse
Norm = Rnd * PARTICLE_MAX_OWN_SPD + 1
Theta = Rnd * 2 * Pi 'Equipartition centrale
.V0.X = Norm * Cos(Theta) - V0.X
.V0.Y = Norm * Sin(Theta) - V0.Y

'Définit la taille initiale
.w0 = Rnd * (PARTICLE_MAX_SIZE - PARTICLE_MIN_SIZE) +
PARTICLE_MIN_SIZE
End With
Next i

PGroups(GetFireworks).Alive = True
Else
GetFireworks = -1
End If
End Function

Private Sub Form_Resize()
On Error Resume Next 'Ignore les erreurs de dimensionnement
impossible
pctBackBuffer.Width = Me.ScaleWidth
pctBackBuffer.Height = Me.ScaleHeight

GenStars
End Sub

--
Picalausa François

Picalausa François wrote:

Hello,

Bonne année, avec plus ou moins d'heures d'avance/de retard en
fonction de la timezone à tous!
Que VB soit avec vous, ainsi que l'argent, le succès, et tout ce que
vous souhaitez pour 2006.

A Happy New Year to you too François!
Et à toutes et à tous qui participent ici.

Clive

Merci François pour le beau feu d'artifice !

Voici aussi mes voeux,

Copier simplement dans une form, sans rien d'autre:

Option Explicit
Const a As String = "Cpoof!fu!ifvsfvtf!booêf!3117!"""
Const d As String = "Nfjmmfvst!wpfvy!"""
Private t As Variant
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Declare Function Beep Lib "kernel32" _
(ByVal dwFreq As Long, _
ByVal dwDuration As Long) As Long
Function b(c As String) As String
b = Chr$(-1 + Asc(m(c, 1)))
End Function
Function e(f As String, g As Long)
If g = 1 Then
e = e & b(m(f, g))
Else
e = e(f, g - 1) & b(m(f, g))
End If
End Function
Sub h(k As Variant, l As Long)
Beep k, l
End Sub
Function m(n As String, o As Long) As String
m = Mid$(n, o, 1)
End Function
Sub Form_activate()
Static q As Boolean
If Not q Then q = Not q: r:
End Sub
Sub r()
Dim p As Long, s As Long, z As Long
Dim u As Long, v As Long, w As Long, x As Long
Me.Width = 12000: Me.Left = (Screen.Width - Me.Width) / 2
Me.Caption = e(d, Len(d))
t = Array(0, 148, 198, 198, 220, 198, 187, 165, _
165, 165, 220, 220, 247, 220, 198, 187, 148, _
148, 247, 247, 264, 247, 220, 198, 165, 148, _
148, 165, 220, 187, 198): s = 1
Me.FontName = "Arial": Me.FontSize = 28: p = 1
Me.FontBold = True: Me.CurrentY = Form1.Height / 3
u = 255: v = 0: w = 0: x = -5
While Not False
Me.ForeColor = RGB(u, v, w): Me.CurrentX = 200 + p * 380
Me.Print b(m(a, p));: p = (p + 1) Mod (Len(a) + 1)
If p = 0 Then p = 1: z = (z + 1) Mod 2: If z = 0 Then s = 1
DoEvents
If s <= UBound(t) Then
h t(s) * 1.5, 280: s = s + 1
Else
Sleep (200)
End If
u = u + x: v = v - x
If (u < 5) Or (u > 250) Then x = -x
Wend
End Sub
Private Sub Form_DblClick()
End ' une fois n'est pas coutume !
End Sub

--
Jean-marc
Tester mon serveur (VB6) => http://myjmnhome.dyndns.org
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ; _no_spam_jean_marc_n2@yahoo.fr

Hello,

Pour répondre à ta question, le plaquage d'icônes sur barres d'outils se
fait pour certains addins à l'aide du presse papier... les addins soucieux
de leurs utilisateurs tendent à rendre le presse papier comme ils l'ont
trouvé.

--
Picalausa François

"Guy DETIENNE" <gd@NOSPAM.tchao.be> a écrit dans le message de news:
%23QvksBmDGHA.2040@TK2MSFTNGP14.phx.gbl...

Je ne sais pas ce que fait VB au démarrage, mais il vire le contenu du
presse-papier...

Bonne et heureuse année à tous et encore de longues lignes de code en VB ...



"Jean-Marc" <NO_SPAM_jean_marc_n2@yahoo.fr> a écrit dans le message de news:
43b717c0$0$6063$ba620e4c@news.skynet.be...

Merci François pour le beau feu d'artifice !

Voici aussi mes voeux,

Copier simplement dans une form, sans rien d'autre:

Option Explicit
Const a As String = "Cpoof!fu!ifvsfvtf!booêf!3117!"""
Const d As String = "Nfjmmfvst!wpfvy!"""
Private t As Variant
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Declare Function Beep Lib "kernel32" _
(ByVal dwFreq As Long, _
ByVal dwDuration As Long) As Long
Function b(c As String) As String
b = Chr$(-1 + Asc(m(c, 1)))
End Function
Function e(f As String, g As Long)
If g = 1 Then
e = e & b(m(f, g))
Else
e = e(f, g - 1) & b(m(f, g))
End If
End Function
Sub h(k As Variant, l As Long)
Beep k, l
End Sub
Function m(n As String, o As Long) As String
m = Mid$(n, o, 1)
End Function
Sub Form_activate()
Static q As Boolean
If Not q Then q = Not q: r:
End Sub
Sub r()
Dim p As Long, s As Long, z As Long
Dim u As Long, v As Long, w As Long, x As Long
Me.Width = 12000: Me.Left = (Screen.Width - Me.Width) / 2
Me.Caption = e(d, Len(d))
t = Array(0, 148, 198, 198, 220, 198, 187, 165, _
165, 165, 220, 220, 247, 220, 198, 187, 148, _
148, 247, 247, 264, 247, 220, 198, 165, 148, _
148, 165, 220, 187, 198): s = 1
Me.FontName = "Arial": Me.FontSize = 28: p = 1
Me.FontBold = True: Me.CurrentY = Form1.Height / 3
u = 255: v = 0: w = 0: x = -5
While Not False
Me.ForeColor = RGB(u, v, w): Me.CurrentX = 200 + p * 380
Me.Print b(m(a, p));: p = (p + 1) Mod (Len(a) + 1)
If p = 0 Then p = 1: z = (z + 1) Mod 2: If z = 0 Then s = 1
DoEvents
If s <= UBound(t) Then
h t(s) * 1.5, 280: s = s + 1
Else
Sleep (200)
End If
u = u + x: v = v - x
If (u < 5) Or (u > 250) Then x = -x
Wend
End Sub
Private Sub Form_DblClick()
End ' une fois n'est pas coutume !
End Sub

--
Jean-marc
Tester mon serveur (VB6) => http://myjmnhome.dyndns.org
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ; _no_spam_jean_marc_n2@yahoo.fr

Cher Monsieur,

J'ai le devoir de vous signaler que vos propos n'entre pas dans la
charte des forums Microsoft :o)

Bonne année à toi aussi, tu as oublié la santé, ça peut servir :o)

@+, bye, Joe.













"Picalausa François" <fpicalausa@chez.com> a écrit dans le message de news:
u9iaKvlDGHA.344@TK2MSFTNGP11.phx.gbl...
| Hello,
|
| Bonne année, avec plus ou moins d'heures d'avance/de retard en fonction de
| la timezone à tous!
| Que VB soit avec vous, ainsi que l'argent, le succès, et tout ce que vous
| souhaitez pour 2006.
|
| Voici un bout de code, à copier coller dans une form contenant une
| picturebox, pctBackBuffer, pour voir ces voeux en couleur:
| Option Explicit
|
| Private Const TimePerYear As Single = 0.002 'Temps entre l'update de
| chaque année
| Private Const Yinc As Long = 6 'Incrément utilisé entre
| deux calculs
| Private Const MinTimePerGlitch As Single = 2 'Temps minimum pour le
| retour en arrière
| Private Const MinTimePerGlitchRndPart As Single = 4 'Modification sur cd
| temps minimum
| Private Const YStop As Long = 2006 'L'année!
| Private Const YGlitchStop As Long = 1000 'L'année de retour
minimale
|
| Private Const ConsumptionRate As Single = 0.2 'vitesse à laquelle
diminue
| la particule
| '(w = w0 - w0 *
| ConsumptionRate * (t - t0))
| Private Const Pi As Single = 3.14159265 'pi, pas le g!
|
| Private Const PARTICLES_COUNT = 150 'nombre de particules par
| feu d'artifice
| Private Const PARTICLE_MAX_OWN_SPD = 1050 'Vitesse max propre à une
| particule (répartie entre x et y)
| Private Const PARTICLE_MAX_SIZE = 78 'Taille maximale de la
| particule
| Private Const PARTICLE_MIN_SIZE = 3 'Taille minimale de la
| particule
| Private Const PGROUP_V0X_MAX = 750 'Vitesse max de la fusée
en
| X, lors de l'explosion
| Private Const PGROUP_V0Y_MAX = 1000 'Vitesse max de la fusée
en
| Y, lors de l'explosion
|
| Private Const PARTICLES_MAX_SPD = 150 'nombre de particules par
| feu d'artifice
| Private Const MAX_GROUPS = 5 'maximum de feux
d'artifices
| en même temps à l'écran
| Private Const STARS_PER_2250000_SQTWIPS = 5 'Nombre d'étoiles par
| 2250000 twips ² (100x100 pixels en général)
|
| 'Définition d'un vecteur
| Private Type VECT
| X As Single
| Y As Single
| End Type
|
| 'Définition composante/composante d'une couleur (ici, ARGB)
| Private Type ARGBColor
| Alpha As Byte
| R As Byte
| G As Byte
| B As Byte
| End Type
|
| 'Un fond étoilé?
| Private Type STAR
| X As VECT
| W As Single
| Color As ARGBColor
| End Type
|
| 'Définition d'une particule de feu d'artifice
| Private Type PARTICLE
| w0 As Single 'dimension initiale
| Color As ARGBColor 'couleur de la particule
| V0 As VECT 'vitesse initiale
| t0 As Single 'première apparition
| x0 As VECT 'position initiale
| End Type
|
| Private Type ParticleGroup
| Particles(1 To PARTICLES_COUNT) As PARTICLE 'Chaque particule
| composant le feu d'artifice
| Alive As Boolean 'Y a-t-il encore des
| particules en vie?
| End Type
|
| Private mColorTimeStart As Single 'Temps de début de la
| transition
| Private mColorTimeEnd As Single 'Temps de fin de la
| transition
| Private mBaseColor As ARGBColor 'Couleur de laquelle
on
| part
| Private mEndColor As ARGBColor 'Couleur à laquelle on
| arrive
| Private mCurrentYear As Long 'Compteur pour le
| défilement des années
| Private mbRunning As Long 'Le programme tourne?
| Private PGroups(1 To MAX_GROUPS) As ParticleGroup 'Feux d'artifice en
| cours
| Private Stars() As STAR 'Etoiles dans
l'univers
| Private mbRenderStars As Boolean 'Effectuer le rendu
| des étoiles (touche s)
| Private mbRenderFW As Boolean 'Effectuer le rendu
| des feux d'artifice (touche f)
|
|
| 'Détermine une couleur pseudo aléatoire
| Private Function RandomColor() As ARGBColor
| RandomColor.R = Rnd * 255
| RandomColor.G = Rnd * 255
| RandomColor.B = Rnd * 255
| End Function
|
| 'Détermine une couleur jaune pseudo aléatoire
| Private Function RandomYellowColor() As ARGBColor
| Dim BaseColor As Byte, LessBlue As Byte
|
| 'Décallage vers le jaune
| LessBlue = Rnd * 32
|
| 'Couleur en niveau de gris
| BaseColor = 255 - Rnd * 128
|
| RandomYellowColor.R = BaseColor
| RandomYellowColor.G = BaseColor
| RandomYellowColor.B = BaseColor - LessBlue
| End Function
|
| 'Effectue une interpolation linéaire entre deux couleurs compos/compos
| Private Function Interpolate( _
| Color1 As ARGBColor, _
| Color2 As ARGBColor, _
| Frame As Single) As ARGBColor
|
| 'Ne devrait pas se produire... juste au cas où!
| If Frame < 0 Then Frame = 0
| If Frame > 1 Then Frame = 1
|
| Interpolate.R = Color1.R + (CSng(Color2.R) - Color1.R) * Frame
| Interpolate.G = Color1.G + (CSng(Color2.G) - Color1.G) * Frame
| Interpolate.B = Color1.B + (CSng(Color2.B) - Color1.B) * Frame
| End Function
|
| 'Trace les étoiles sur le fond pour réutilisation intensive
| Private Sub RenderStars()
| Dim i As Long
|
| pctBackBuffer.Cls
| Set pctBackBuffer.Picture = Nothing
| pctBackBuffer.DrawStyle = 5 'transparent
| pctBackBuffer.FillStyle = 0 'Solid
|
| If mbRenderStars Then
| 'trace le fond étoilé
| For i = 0 To UBound(Stars)
| pctBackBuffer.FillColor = GetRGB(Stars(i).Color)
| pctBackBuffer.Circle (Stars(i).X.X, Stars(i).X.Y), Stars(i).W
| Next i
| End If
|
| Set pctBackBuffer.Picture = pctBackBuffer.Image
|
| pctBackBuffer.DrawStyle = 0 'solid
| pctBackBuffer.FillStyle = 1 'transparent
| End Sub
|
| 'Effectue le tracé des données
| Private Sub Render()
| Dim Color As ARGBColor, strYear As String, BlackColor As ARGBColor
| Dim i As Long, j As Long
| Dim Position As VECT, LifeTime As Single, Spd As VECT
|
| Const Text1 As String = " Megabytes of free memory"
| Const Text2 As String = "Happy new year!"
|
| 'Efface les données précédentes
| pctBackBuffer.Cls
|
| 'Calcule la nouvelle couleur
| If (mColorTimeEnd - mColorTimeStart) <> 0 Then
| Color = Interpolate(mBaseColor, mEndColor, (Timer -
mColorTimeStart)
| / (mColorTimeEnd - mColorTimeStart))
| End If
| pctBackBuffer.ForeColor = GetRGB(Color)
|
| 'Détermine la première partie du texte à afficher
| strYear = Format(mCurrentYear, "0000") & Text1
|
| 'Affiche la première partie du texte
| pctBackBuffer.CurrentX = (pctBackBuffer.ScaleWidth -
| pctBackBuffer.TextWidth(strYear)) / 2
| pctBackBuffer.CurrentY = (pctBackBuffer.ScaleHeight -
| pctBackBuffer.TextHeight(strYear & vbCrLf)) / 2
| pctBackBuffer.Print strYear
|
| 'Seulle la nouvelle année est spéciale
| If mCurrentYear = YStop Then
| pctBackBuffer.CurrentX = (pctBackBuffer.ScaleWidth -
| pctBackBuffer.TextWidth(Text2)) / 2
| pctBackBuffer.CurrentY = (pctBackBuffer.ScaleHeight -
| pctBackBuffer.TextHeight(strYear & vbCrLf)) / 2 +
| pctBackBuffer.TextHeight(strYear & vbCrLf) - Me.TextHeight(Text2)
| pctBackBuffer.Print Text2
| End If
|
|
| 'Trace les feu d'artifice en cours
| pctBackBuffer.DrawStyle = 5 'transparent
| pctBackBuffer.FillStyle = 0 'Solid
|
| If mbRenderFW Then
| For j = 1 To MAX_GROUPS
| If PGroups(j).Alive Then
| PGroups(j).Alive = False
| For i = 1 To PARTICLES_COUNT
| With PGroups(j).Particles(i)
| 'Age de la particule
| LifeTime = (Timer - .t0)
|
| If .w0 - ConsumptionRate * .w0 * LifeTime > 0 Then
| PGroups(j).Alive = True
|
| 'Calcule les nouvelles vitesses
| Spd.X = .V0.X
| Spd.Y = (LifeTime * 200 + .V0.Y) 'supposé
indép
| du poids
|
| 'Calcule la position de la particule
| Position.X = .x0.X + Spd.X * LifeTime
| Position.Y = .x0.Y + Spd.Y * LifeTime
|
| 'Trace la particule
| pctBackBuffer.FillColor | GetRGB(Interpolate(.Color, BlackColor, LifeTime * ConsumptionRate))
| pctBackBuffer.Circle (Position.X, Position.Y),
| .w0 - ConsumptionRate * .w0 * LifeTime
| End If
| End With
| Next i
| End If
| Next j
| End If
|
| pctBackBuffer.DrawStyle = 0 'solid
| pctBackBuffer.FillStyle = 1 'transparent
|
| End Sub
|
| 'Retourne la couleur vb à partir d'une structure ARGBColor
| Private Function GetRGB(Color As ARGBColor) As Long
| GetRGB = RGB(Color.R, Color.G, Color.B)
| End Function
|
| 'Affiche le tracé à l'écran
| Private Sub Present()
| Set Me.Picture = pctBackBuffer.Image
| End Sub
|
| Private Sub Form_Click()
| mbRunning = False
| End Sub
|
| Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
| Select Case KeyCode
| Case vbKeyS
| mbRenderStars = Not mbRenderStars
| RenderStars
| Case vbKeyF
| mbRenderFW = Not mbRenderFW
| End Select
| End Sub
|
| Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
| mbRunning = False
| End Sub
|
| Private Sub GenStars()
| Dim i As Long
| Dim Surface As Long
| Dim StarsCount As Long
|
| 'Compte le nombre d'étoiles à la surface de l'univers
| Surface = Me.ScaleWidth * Me.ScaleHeight / 2250000
| StarsCount = Surface * STARS_PER_2250000_SQTWIPS
|
| 'Réserve de l'espace galactique pour étoiles
| If StarsCount = 0 Then
| ReDim Stars(-1 To -1)
| Else
| ReDim Stars(0 To StarsCount - 1)
| End If
|
| 'Initialise la galaxie
| For i = 0 To UBound(Stars)
| 'Définit une couleur claire
| Stars(i).Color = RandomYellowColor
|
| 'Chaque étoile à sa propre taille
| Stars(i).W = Rnd * 19 + 3
|
| 'La galaxie se limitera à al partie visible de l'écran
| Stars(i).X.X = Rnd * Me.ScaleWidth
| Stars(i).X.Y = Rnd * Me.ScaleHeight
| Next i
|
| RenderStars
| End Sub
|
| Private Sub Form_Load()
| Dim LastYearTick As Single, TimeToNextGlitch As Single
|
| 'Initialise diverses propriétés
| pctBackBuffer.FontSize = 15
| pctBackBuffer.BorderStyle = 0
| pctBackBuffer.AutoRedraw = True
| pctBackBuffer.Visible = False
|
| 'Par défaut on suppose qu'on a une bonne machine
| mbRenderStars = True
| mbRenderFW = True
|
| 'C'est plus joli la nuit
| pctBackBuffer.BackColor = vbBlack
| GenStars
|
| 'Génère la couleur de *départ*
| mEndColor = RandomColor
|
| 'Précalcule le temps de l'erreur suivante
| TimeToNextGlitch = MinTimePerGlitch + MinTimePerGlitchRndPart * Rnd
|
| 'Avec affichage c'est mieux
| Me.Show
| 'Et si l'affichage change à chaque fois c'est encore mieux
| Randomize Timer
|
| 'Fait tourner le programme
| mbRunning = True
|
| While (mbRunning)
| 'Incrémente les années, tant qu'il y en a a passer
| If Timer - LastYearTick > TimePerYear And mCurrentYear < YStop Then
| mCurrentYear = mCurrentYear + Yinc
| If mCurrentYear > YStop Then mCurrentYear = YStop
| LastYearTick = Timer
| End If
|
| 'Déja finit de compter? revient de temps à autres en arrière
| If mCurrentYear = YStop And Timer - LastYearTick > TimeToNextGlitch
| Then
| TimeToNextGlitch = MinTimePerGlitch + MinTimePerGlitchRndPart *
| Rnd
| mCurrentYear = YStop - Rnd * (YStop - YGlitchStop)
| LastYearTick = Timer
| End If
|
| 'Vérifie si on doit calculer une nouvelle transition de couleurs
| If mColorTimeEnd < Timer Then
| mColorTimeStart = Timer
| mColorTimeEnd = Timer + 1 + Rnd * 2
| mBaseColor = mEndColor
| mEndColor = RandomColor
|
| GetFireworks Rnd * Me.ScaleWidth, Rnd * Me.ScaleHeight,
| mEndColor
| End If
|
| 'Trace les données à jour
| Render
| 'Les affiche à l'écran
| Present
| 'Il faut respirer
| DoEvents
| Wend
|
| 'On sort... à la fin
| Unload Me
| End Sub
|
| 'Génère un feu d'artifice prêt à l'emploi
| Private Function GetFireworks(X As Single, Y As Single, Color As
ARGBColor)
| As Long
| Dim i As Long, Norm As Single, Theta As Single, V0 As VECT
|
| 'Trouve le groupe qui sera utilisé
| For GetFireworks = 1 To MAX_GROUPS
| If PGroups(GetFireworks).Alive = False Then
| Exit For
| End If
| Next
|
| 'Y a-t-il encore des groupes disponibles?
| If GetFireworks < MAX_GROUPS + 1 Then
| 'Définit une vitesse de montée initiale
| V0.Y = Rnd * PGROUP_V0Y_MAX
| V0.X = Rnd * PGROUP_V0X_MAX * 2 - PGROUP_V0X_MAX
|
| 'Initialise chaque particule
| For i = 1 To PARTICLES_COUNT
| With PGroups(GetFireworks).Particles(i)
| 'Couleur et temps de création, position initiale
| .Color = Color
| .t0 = Timer
| .x0.X = X
| .x0.Y = Y
|
| 'Norme et direction de la modification au vecteur vitesse
| Norm = Rnd * PARTICLE_MAX_OWN_SPD + 1
| Theta = Rnd * 2 * Pi 'Equipartition centrale
| .V0.X = Norm * Cos(Theta) - V0.X
| .V0.Y = Norm * Sin(Theta) - V0.Y
|
| 'Définit la taille initiale
| .w0 = Rnd * (PARTICLE_MAX_SIZE - PARTICLE_MIN_SIZE) +
| PARTICLE_MIN_SIZE
| End With
| Next i
|
| PGroups(GetFireworks).Alive = True
| Else
| GetFireworks = -1
| End If
| End Function
|
| Private Sub Form_Resize()
| On Error Resume Next 'Ignore les erreurs de dimensionnement
| impossible
| pctBackBuffer.Width = Me.ScaleWidth
| pctBackBuffer.Height = Me.ScaleHeight
|
| GenStars
| End Sub
|
| --
| Picalausa François
|
|

Picalausa François a écrit :

Hello,

Bonjour à tous,

VB6 à un sursis de 6 mois...

Liste des produits retirés
le 31 décembre 2005
• Application Center 2000
• BizTalk Server 2000
• Commerce Server 2000
• Commerce Server 2000 Resource Kit
• Embedded Visual Tools 3.0 (2002 Edition)
• Exchange Server 5.5 & 2000
• ISA Server 2000
• Microsoft Plus ! 98
• FrontPage 2000 Server Extensions
• Handheld PC 2000 SDK
• Site Server 3
• Small Business Server 2000
• SNA Server 4.0 Service Pack 3 & Service Pack 4
• System Management Server 2
• Visual C++ (Alpha Systems)
• Visual FoxPro 6.0
• Visual SourceSafe 6.0c & 6.0d
• Visual Studio 6.0
• Windows CE Toolkit for Visual C++ 6.0
• Windows CE SDKs & DDKs
• Infrared Communications for Windows 95 DDK
• DCOM for Windows 95 v1.1
• Windows 98
• Windows 98 DDK
• Windows 2000
• Windows 2000 DDK
• Windows ME
• Windows NT 4.0
• Windows NT 4.0 DDK
• System Stress for Windows NT 4.0 & Windows 2000


--
Cordialement,

Jacques.

Bonjour à tous, et spécialement à François PICALAUSA,

Bonne année, et qu'il (ainsi que les autres interveneantsà
continue(nt)toujours à nous répondre de façon aussi agréable et rapide,

Beaucoup de problèmes résolus rapidement,

Merci encore,

Pierre

"Picalausa François" <fpicalausa@chez.com> a écrit dans le message de news:
u9iaKvlDGHA.344@TK2MSFTNGP11.phx.gbl...

Hello,

Bonne année, avec plus ou moins d'heures d'avance/de retard en fonction de
la timezone à tous!
Que VB soit avec vous, ainsi que l'argent, le succès, et tout ce que vous
souhaitez pour 2006.

Voici un bout de code, à copier coller dans une form contenant une
picturebox, pctBackBuffer, pour voir ces voeux en couleur:
Option Explicit

Private Const TimePerYear As Single = 0.002 'Temps entre l'update de
chaque année
Private Const Yinc As Long = 6 'Incrément utilisé entre
deux calculs
Private Const MinTimePerGlitch As Single = 2 'Temps minimum pour le
retour en arrière
Private Const MinTimePerGlitchRndPart As Single = 4 'Modification sur cd
temps minimum
Private Const YStop As Long = 2006 'L'année!
Private Const YGlitchStop As Long = 1000 'L'année de retour
minimale

Private Const ConsumptionRate As Single = 0.2 'vitesse à laquelle
diminue la particule
'(w = w0 - w0 *
ConsumptionRate * (t - t0))
Private Const Pi As Single = 3.14159265 'pi, pas le g!

Private Const PARTICLES_COUNT = 150 'nombre de particules par
feu d'artifice
Private Const PARTICLE_MAX_OWN_SPD = 1050 'Vitesse max propre à une
particule (répartie entre x et y)
Private Const PARTICLE_MAX_SIZE = 78 'Taille maximale de la
particule
Private Const PARTICLE_MIN_SIZE = 3 'Taille minimale de la
particule
Private Const PGROUP_V0X_MAX = 750 'Vitesse max de la fusée
en X, lors de l'explosion
Private Const PGROUP_V0Y_MAX = 1000 'Vitesse max de la fusée
en Y, lors de l'explosion

Private Const PARTICLES_MAX_SPD = 150 'nombre de particules par
feu d'artifice
Private Const MAX_GROUPS = 5 'maximum de feux
d'artifices en même temps à l'écran
Private Const STARS_PER_2250000_SQTWIPS = 5 'Nombre d'étoiles par
2250000 twips ² (100x100 pixels en général)

'Définition d'un vecteur
Private Type VECT
X As Single
Y As Single
End Type

'Définition composante/composante d'une couleur (ici, ARGB)
Private Type ARGBColor
Alpha As Byte
R As Byte
G As Byte
B As Byte
End Type

'Un fond étoilé?
Private Type STAR
X As VECT
W As Single
Color As ARGBColor
End Type

'Définition d'une particule de feu d'artifice
Private Type PARTICLE
w0 As Single 'dimension initiale
Color As ARGBColor 'couleur de la particule
V0 As VECT 'vitesse initiale
t0 As Single 'première apparition
x0 As VECT 'position initiale
End Type

Private Type ParticleGroup
Particles(1 To PARTICLES_COUNT) As PARTICLE 'Chaque particule
composant le feu d'artifice
Alive As Boolean 'Y a-t-il encore des
particules en vie?
End Type

Private mColorTimeStart As Single 'Temps de début de la
transition
Private mColorTimeEnd As Single 'Temps de fin de la
transition
Private mBaseColor As ARGBColor 'Couleur de laquelle
on part
Private mEndColor As ARGBColor 'Couleur à laquelle on
arrive
Private mCurrentYear As Long 'Compteur pour le
défilement des années
Private mbRunning As Long 'Le programme tourne?
Private PGroups(1 To MAX_GROUPS) As ParticleGroup 'Feux d'artifice en
cours
Private Stars() As STAR 'Etoiles dans
l'univers
Private mbRenderStars As Boolean 'Effectuer le rendu
des étoiles (touche s)
Private mbRenderFW As Boolean 'Effectuer le rendu
des feux d'artifice (touche f)


'Détermine une couleur pseudo aléatoire
Private Function RandomColor() As ARGBColor
RandomColor.R = Rnd * 255
RandomColor.G = Rnd * 255
RandomColor.B = Rnd * 255
End Function

'Détermine une couleur jaune pseudo aléatoire
Private Function RandomYellowColor() As ARGBColor
Dim BaseColor As Byte, LessBlue As Byte

'Décallage vers le jaune
LessBlue = Rnd * 32

'Couleur en niveau de gris
BaseColor = 255 - Rnd * 128

RandomYellowColor.R = BaseColor
RandomYellowColor.G = BaseColor
RandomYellowColor.B = BaseColor - LessBlue
End Function

'Effectue une interpolation linéaire entre deux couleurs compos/compos
Private Function Interpolate( _
Color1 As ARGBColor, _
Color2 As ARGBColor, _
Frame As Single) As ARGBColor

'Ne devrait pas se produire... juste au cas où!
If Frame < 0 Then Frame = 0
If Frame > 1 Then Frame = 1

Interpolate.R = Color1.R + (CSng(Color2.R) - Color1.R) * Frame
Interpolate.G = Color1.G + (CSng(Color2.G) - Color1.G) * Frame
Interpolate.B = Color1.B + (CSng(Color2.B) - Color1.B) * Frame
End Function

'Trace les étoiles sur le fond pour réutilisation intensive
Private Sub RenderStars()
Dim i As Long

pctBackBuffer.Cls
Set pctBackBuffer.Picture = Nothing
pctBackBuffer.DrawStyle = 5 'transparent
pctBackBuffer.FillStyle = 0 'Solid

If mbRenderStars Then
'trace le fond étoilé
For i = 0 To UBound(Stars)
pctBackBuffer.FillColor = GetRGB(Stars(i).Color)
pctBackBuffer.Circle (Stars(i).X.X, Stars(i).X.Y), Stars(i).W
Next i
End If

Set pctBackBuffer.Picture = pctBackBuffer.Image

pctBackBuffer.DrawStyle = 0 'solid
pctBackBuffer.FillStyle = 1 'transparent
End Sub

'Effectue le tracé des données
Private Sub Render()
Dim Color As ARGBColor, strYear As String, BlackColor As ARGBColor
Dim i As Long, j As Long
Dim Position As VECT, LifeTime As Single, Spd As VECT

Const Text1 As String = " Megabytes of free memory"
Const Text2 As String = "Happy new year!"

'Efface les données précédentes
pctBackBuffer.Cls

'Calcule la nouvelle couleur
If (mColorTimeEnd - mColorTimeStart) <> 0 Then
Color = Interpolate(mBaseColor, mEndColor, (Timer -
mColorTimeStart) / (mColorTimeEnd - mColorTimeStart))
End If
pctBackBuffer.ForeColor = GetRGB(Color)

'Détermine la première partie du texte à afficher
strYear = Format(mCurrentYear, "0000") & Text1

'Affiche la première partie du texte
pctBackBuffer.CurrentX = (pctBackBuffer.ScaleWidth -
pctBackBuffer.TextWidth(strYear)) / 2
pctBackBuffer.CurrentY = (pctBackBuffer.ScaleHeight -
pctBackBuffer.TextHeight(strYear & vbCrLf)) / 2
pctBackBuffer.Print strYear

'Seulle la nouvelle année est spéciale
If mCurrentYear = YStop Then
pctBackBuffer.CurrentX = (pctBackBuffer.ScaleWidth -
pctBackBuffer.TextWidth(Text2)) / 2
pctBackBuffer.CurrentY = (pctBackBuffer.ScaleHeight -
pctBackBuffer.TextHeight(strYear & vbCrLf)) / 2 +
pctBackBuffer.TextHeight(strYear & vbCrLf) - Me.TextHeight(Text2)
pctBackBuffer.Print Text2
End If


'Trace les feu d'artifice en cours
pctBackBuffer.DrawStyle = 5 'transparent
pctBackBuffer.FillStyle = 0 'Solid

If mbRenderFW Then
For j = 1 To MAX_GROUPS
If PGroups(j).Alive Then
PGroups(j).Alive = False
For i = 1 To PARTICLES_COUNT
With PGroups(j).Particles(i)
'Age de la particule
LifeTime = (Timer - .t0)

If .w0 - ConsumptionRate * .w0 * LifeTime > 0 Then
PGroups(j).Alive = True

'Calcule les nouvelles vitesses
Spd.X = .V0.X
Spd.Y = (LifeTime * 200 + .V0.Y) 'supposé
indép du poids

'Calcule la position de la particule
Position.X = .x0.X + Spd.X * LifeTime
Position.Y = .x0.Y + Spd.Y * LifeTime

'Trace la particule
pctBackBuffer.FillColor =
GetRGB(Interpolate(.Color, BlackColor, LifeTime * ConsumptionRate))
pctBackBuffer.Circle (Position.X, Position.Y),
.w0 - ConsumptionRate * .w0 * LifeTime
End If
End With
Next i
End If
Next j
End If

pctBackBuffer.DrawStyle = 0 'solid
pctBackBuffer.FillStyle = 1 'transparent

End Sub

'Retourne la couleur vb à partir d'une structure ARGBColor
Private Function GetRGB(Color As ARGBColor) As Long
GetRGB = RGB(Color.R, Color.G, Color.B)
End Function

'Affiche le tracé à l'écran
Private Sub Present()
Set Me.Picture = pctBackBuffer.Image
End Sub

Private Sub Form_Click()
mbRunning = False
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyS
mbRenderStars = Not mbRenderStars
RenderStars
Case vbKeyF
mbRenderFW = Not mbRenderFW
End Select
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
mbRunning = False
End Sub

Private Sub GenStars()
Dim i As Long
Dim Surface As Long
Dim StarsCount As Long

'Compte le nombre d'étoiles à la surface de l'univers
Surface = Me.ScaleWidth * Me.ScaleHeight / 2250000
StarsCount = Surface * STARS_PER_2250000_SQTWIPS

'Réserve de l'espace galactique pour étoiles
If StarsCount = 0 Then
ReDim Stars(-1 To -1)
Else
ReDim Stars(0 To StarsCount - 1)
End If

'Initialise la galaxie
For i = 0 To UBound(Stars)
'Définit une couleur claire
Stars(i).Color = RandomYellowColor

'Chaque étoile à sa propre taille
Stars(i).W = Rnd * 19 + 3

'La galaxie se limitera à al partie visible de l'écran
Stars(i).X.X = Rnd * Me.ScaleWidth
Stars(i).X.Y = Rnd * Me.ScaleHeight
Next i

RenderStars
End Sub

Private Sub Form_Load()
Dim LastYearTick As Single, TimeToNextGlitch As Single

'Initialise diverses propriétés
pctBackBuffer.FontSize = 15
pctBackBuffer.BorderStyle = 0
pctBackBuffer.AutoRedraw = True
pctBackBuffer.Visible = False

'Par défaut on suppose qu'on a une bonne machine
mbRenderStars = True
mbRenderFW = True

'C'est plus joli la nuit
pctBackBuffer.BackColor = vbBlack
GenStars

'Génère la couleur de *départ*
mEndColor = RandomColor

'Précalcule le temps de l'erreur suivante
TimeToNextGlitch = MinTimePerGlitch + MinTimePerGlitchRndPart * Rnd

'Avec affichage c'est mieux
Me.Show
'Et si l'affichage change à chaque fois c'est encore mieux
Randomize Timer

'Fait tourner le programme
mbRunning = True

While (mbRunning)
'Incrémente les années, tant qu'il y en a a passer
If Timer - LastYearTick > TimePerYear And mCurrentYear < YStop Then
mCurrentYear = mCurrentYear + Yinc
If mCurrentYear > YStop Then mCurrentYear = YStop
LastYearTick = Timer
End If

'Déja finit de compter? revient de temps à autres en arrière
If mCurrentYear = YStop And Timer - LastYearTick > TimeToNextGlitch
Then
TimeToNextGlitch = MinTimePerGlitch + MinTimePerGlitchRndPart *
Rnd
mCurrentYear = YStop - Rnd * (YStop - YGlitchStop)
LastYearTick = Timer
End If

'Vérifie si on doit calculer une nouvelle transition de couleurs
If mColorTimeEnd < Timer Then
mColorTimeStart = Timer
mColorTimeEnd = Timer + 1 + Rnd * 2
mBaseColor = mEndColor
mEndColor = RandomColor

GetFireworks Rnd * Me.ScaleWidth, Rnd * Me.ScaleHeight,
mEndColor
End If

'Trace les données à jour
Render
'Les affiche à l'écran
Present
'Il faut respirer
DoEvents
Wend

'On sort... à la fin
Unload Me
End Sub

'Génère un feu d'artifice prêt à l'emploi
Private Function GetFireworks(X As Single, Y As Single, Color As
ARGBColor) As Long
Dim i As Long, Norm As Single, Theta As Single, V0 As VECT

'Trouve le groupe qui sera utilisé
For GetFireworks = 1 To MAX_GROUPS
If PGroups(GetFireworks).Alive = False Then
Exit For
End If
Next

'Y a-t-il encore des groupes disponibles?
If GetFireworks < MAX_GROUPS + 1 Then
'Définit une vitesse de montée initiale
V0.Y = Rnd * PGROUP_V0Y_MAX
V0.X = Rnd * PGROUP_V0X_MAX * 2 - PGROUP_V0X_MAX

'Initialise chaque particule
For i = 1 To PARTICLES_COUNT
With PGroups(GetFireworks).Particles(i)
'Couleur et temps de création, position initiale
.Color = Color
.t0 = Timer
.x0.X = X
.x0.Y = Y

'Norme et direction de la modification au vecteur vitesse
Norm = Rnd * PARTICLE_MAX_OWN_SPD + 1
Theta = Rnd * 2 * Pi 'Equipartition centrale
.V0.X = Norm * Cos(Theta) - V0.X
.V0.Y = Norm * Sin(Theta) - V0.Y

'Définit la taille initiale
.w0 = Rnd * (PARTICLE_MAX_SIZE - PARTICLE_MIN_SIZE) +
PARTICLE_MIN_SIZE
End With
Next i

PGroups(GetFireworks).Alive = True
Else
GetFireworks = -1
End If
End Function

Private Sub Form_Resize()
On Error Resume Next 'Ignore les erreurs de dimensionnement
impossible
pctBackBuffer.Width = Me.ScaleWidth
pctBackBuffer.Height = Me.ScaleHeight

GenStars
End Sub

--
Picalausa François

Voilà enfin pourquoi ce fichu presse-papier se vide à chaque fois...

Merci.

Guy


"Picalausa François" <fpicalausa@chez.com> a écrit dans le message de
news:eveXvvmDGHA.344@TK2MSFTNGP11.phx.gbl...

Hello,

Pour répondre à ta question, le plaquage d'icônes sur barres d'outils se
fait pour certains addins à l'aide du presse papier... les addins soucieux
de leurs utilisateurs tendent à rendre le presse papier comme ils l'ont
trouvé.

--
Picalausa François

"Guy DETIENNE" <gd@NOSPAM.tchao.be> a écrit dans le message de news:
%23QvksBmDGHA.2040@TK2MSFTNGP14.phx.gbl...
> Je ne sais pas ce que fait VB au démarrage, mais il vire le contenu du
> presse-papier...

Bonne année à vous tous.

Loïc