un petit programme spécial pour les loups garous du forum,
ou pour les astronomes amateurs :-)
Il permet de dessiner la lune, pour un jour lunaire donné,
compris entre 0 et 27.
Le principe est basé sur le calcul de la postion du méridien
pour un jour donné, qui vaut:
R * cos(JL*PI/14) * cos(A), avec
- A entre -PI/2 et PI/2, pour parcourir le demi cercle
- JL, le jour lunaire
- R, le rayon du cercle (la lune ici)
Il vous faut:
- 1 label (Label1)
- 2 commandButton:
Command1: pour dessiner la lune pour le jour J donné
Command2: démarre et arrête l'animation
- 1 textBox (Text1) (pour saisir le jour lunaire)
- 1 pictureBox (Picture1)(pour le dessin de la lune)
- 1 Timer (Timer1) (pour l'animation)
' taille de la lune / picturebox
Private Const G_RATIO As Single = (2 / 3)
' PI
Private Const PI As Double = 3.141592657
' pour l'animation
Private Const PAS_ANIMATION As Double = 0.5
' Pour la démo, centre et rayon de la lune
Private G_xc As Single
Private G_yc As Single
Private G_r As Single
' Commande : Dessin de la lune pour un jour donné
' Note: le jour est un flottant
Private Sub Command1_Click()
Dim jl As Double
' vérification de la validité
jl = Val(Text1.Text)
If (jl < 0#) Or (jl > 27#) Then
MsgBox "Entrez une valeur entre 0 et 27 !", vbExclamation, ""
Else
' dessin si OK
Call drawMoon(jl, G_xc, G_yc, G_r)
End If
End Sub
' Graphique : Dessin de la lune au jour JL
Private Sub drawMoon(jl As Double, _
xc As Single, _
yc As Single, _
r As Single)
Dim i As Double
If jl <= 7 Then
' grise le disque gauche
For i = PI / 2 To 3 * PI / 2 Step PI / 1000
Picture1.Line (xc, yc + r * Sin(i))-(xc + r * Cos(i), _
yc + r * Sin(i)), RGB(0, 0, 0)
Next i
' dessine la partie droite
For i = PI / 2 To -PI / 2 Step -PI / 1000
Picture1.Line (xc, yc + r * Sin(i))-(xc + r * Cos(i) * _
Cos(jl * PI / 14), yc + r * Sin(i)), RGB(0, 0, 0)
Picture1.Line (xc + r * Cos(i) * Cos(jl * PI / 14), yc + _
r * Sin(i))-(xc + r * Cos(i) + 10, yc + r * Sin(i)), _
RGB(255, 255, 255)
Next i
ElseIf jl <= 14 Then
' dessine la partie gauche
For i = PI / 2 To 3 * PI / 2 Step PI / 1000
Picture1.Line (xc + r * Cos(i) + 10, yc + r * Sin(i))- _
(xc - r * Cos(i) * Cos(jl * PI / 14), yc + r * Sin(i)), _
RGB(0, 0, 0)
Picture1.Line (xc - r * Cos(i) * Cos(jl * PI / 14), yc + _
r * Sin(i))-(xc, yc + r * Sin(i)), RGB(255, 255, 255)
Next i
ElseIf jl <= 21 Then
' dessine la partie droite
For i = PI / 2 To -PI / 2 Step -PI / 1000
Picture1.Line (xc, yc + r * Sin(i))-(xc - r * Cos(i) * _
Cos(jl * PI / 14), yc + r * Sin(i)), RGB(255, 255, 255)
Picture1.Line (xc - r * Cos(i) * Cos(jl * PI / 14), yc + _
r * Sin(i))-(xc + r * Cos(i) + 10, yc + r * Sin(i)), _
RGB(0, 0, 0)
Next i
Else
' grise le disque droit
For i = PI / 2 To -PI / 2 Step -PI / 1000
Picture1.Line (xc, yc + r * Sin(i))-(xc + r * Cos(i), _
yc + r * Sin(i)), RGB(0, 0, 0)
Next i
For i = PI / 2 To 3 * PI / 2 Step PI / 1000
Picture1.Line (xc, yc + r * Sin(i))-(xc + r * Cos(i) * _
Cos(jl * PI / 14), yc + r * Sin(i)), RGB(0, 0, 0)
Picture1.Line (xc + r * Cos(i) * Cos(jl * PI / 14), yc + _
r * Sin(i))-(xc + r * Cos(i) * 1, yc + r * Sin(i)), _
RGB(255, 255, 255)
Next i
End If
End Sub
' Mise en route ou arret de l'animation
Private Sub Command2_Click()
If Timer1.Enabled = True Then
Timer1.Enabled = False
Else
Timer1.Enabled = True
End If
End Sub
Private Sub Form_Load()
' initialisation des controles
Label1.Caption = "Jour Lunaire (0<=JL<=27)"
Label1.AutoSize = True
Text1.Text = ""
Command1.Caption = "Dessiner"
Command2.Caption = "Animation"
Timer1.Enabled = False
Timer1.Interval = 500
' calcul de la taille et de la position de la lune
' en fonction de la taille du pictureBox
G_xc = Picture1.Width / 2
G_yc = Picture1.Height / 2
G_r = G_RATIO * minimum(G_xc, G_yc)
End Sub
'
Private Function minimum(a As Variant, b As Variant) As Variant
If a < b Then
minimum = a
Else
minimum = b
End If
End Function
'
' Animation de la lune, pas par pas
Private Sub Timer1_Timer()
Static jl As Double
jl = jl + PAS_ANIMATION
If jl > 27 Then
jl = 0
End If
Call drawMoon(jl, G_xc, G_yc, G_r)
End Sub
' 8<-----------------------------------------
Bon amusement :-)
--
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
