Option Explicit
'***********************************************
'Institut de mécanique céleste et de calcul des éphémérides (IMCCE)
'Adaptation du code écrit en Javascript en VB
'Les dates des phases de la Lune sont données avec une précision de quelques minutes.
'https://promenade.imcce.fr/fr/pages4/441.html
'***********************************************
Public Type TypeOar
CODE1 As Integer
End Type
'
Type TypeDate
JJD As Double
An As Integer
mois As Integer
jour As Integer
End Type
'
Public UneDate As TypeDate
Public oar As TypeOar
Dim MonDico As Object
'***********************************************
Function MoonPhases(Annee, Debut, Optional Fin)
'***********************************************
Dim Pi As Double
Dim Tabm As Variant
Dim An
Dim lik
Dim rk
Dim rad
Dim ii
Dim T
Dim t2
Dim t3
Dim M
Dim Mp
Dim F
Dim I, j, k, mois ', n As Integer
Dim Phase As Variant
Dim Cle
'***********************************************
Set MonDico = CreateObject("Scripting.Dictionary")
'
'Pour l'affichage des phases en Symbole Wingdings 2
'PL = Chr(152), PQ = Chr(130), NL = Chr(153),DQ = Chr(131)
Phase = Array(Chr(152), Chr(130), Chr(153), Chr(131))
Tabm = Array(0.041, 0.126, 0.203, 0.288, 0.37, 0.455, 0.537, 0.622, 0.707, 0.789, 0.874, 0.956)
'
UneDate.An = Annee
If Annee > 2500 Or Annee < 1900 Then MsgBox "hors limite": Exit Function
'
If IsMissing(Fin) Then Fin = Debut
For mois = Debut To Fin
UneDate.mois = mois
'
oar.CODE1 = UneDate.An
'
If (UneDate.mois = 1) Then
An = UneDate.An - 1
UneDate.mois = 11
Else
An = UneDate.An
UneDate.mois = UneDate.mois - 1
End If
'
Pi = Round(4 * Atn(1), 15)
An = An + Tabm(UneDate.mois - 1)
k = (An - 1900) * 12.3685
lik = Trunc(k)
rk = lik
k = rk - 0.25
If (k < 0#) Then k = k - 1
rad = Pi / 180#
'
For ii = 0 To 11
k = k + 0.25
T = k / 1236.85
t2 = T * T
t3 = T * t2
'
j = 2415020.75933 + 29.5305888531 * k + _
0.0001337 * t2 - 0.00000015 * t3 + _
0.00033 * Sin(rad * (166.56 + 132.87 * T - 0.009 * t2))
'
M = rad * (359.2242 + 29.10535608 * k - _
-0.0000333 * t2 - 0.00000347 * t3)
M = Modulo(M, 2 * Pi)
'
Mp = rad * (306.0253 + 385.81691806 * k + _
0.0107306 * t2 + 0.00001236 * t3)
Mp = Modulo(Mp, 2 * Pi)
'
F = rad * (21.2964 + 390.67050646 * k + _
-0.0016528 * t2 - 0.00000239 * t3)
F = Modulo(F, 2 * Pi)
'i = 0 à 3 => Array("PL", "PQ", "NL", "DQ")
I = Modulo(ii, 4)
If (I = 0 Or I = 2) Then
'NL,PL
j = j + (0.1734 - 0.000393 * T) * Sin(M) + _
0.0021 * Sin(2 * M) - 0.4068 * Sin(Mp) + _
0.0161 * Sin(2 * Mp) - 0.0004 * Sin(3 * Mp) + _
0.0104 * Sin(2 * F) - 0.0051 * Sin(M + Mp) + _
-0.0074 * Sin(M - Mp) + 0.0004 * Sin(2 * F + M) + _
-0.0004 * Sin(2 * F - M) - 0.0006 * Sin(2 * F + Mp) + _
0.001 * Sin(2 * F - Mp) + 0.0005 * Sin(M + 2 * Mp)
UneDate.JJD = j
Correction I
Cle = Phase(I) & ConvertiDateJulienne(CDbl(UneDate.JJD))
If Not MonDico.Exists(Cle) Then
MonDico.Add Key:=Phase(I) & ConvertiDateJulienne(CDbl(UneDate.JJD)), item:=ConvertiDateJulienne(CDbl(UneDate.JJD))
'n = n + 1
End If
Else
j = j + (0.1721 - 0.0004 * T) * Sin(M) + _
0.0021 * Sin(2 * M) - 0.628 * Sin(Mp) + _
0.0089 * Sin(2 * Mp) - 0.0004 * Sin(3 * Mp) + _
0.0079 * Sin(2 * F) - 0.0119 * Sin(M + Mp) + _
-0.0047 * Sin(M - Mp) + 0.0003 * Sin(2 * F + M) + _
-0.0004 * Sin(2 * F - M) - 0.0006 * Sin(2 * F + Mp) + _
0.0021 * Sin(2 * F - Mp) + 0.0003 * Sin(M + 2 * Mp) + _
0.0004 * Sin(M - 2 * Mp) - 0.0003 * Sin(2 * M + Mp)
If (I = 1) Then
'Premier quartier
UneDate.JJD = j + 0.0028 - 0.0004 * Cos(M) + 0.0003 * Cos(Mp)
Correction I
Cle = Phase(I) & ConvertiDateJulienne(CDbl(UneDate.JJD))
If Not MonDico.Exists(Cle) Then
MonDico.Add Key:=Phase(I) & ConvertiDateJulienne(CDbl(UneDate.JJD)), item:=ConvertiDateJulienne(CDbl(UneDate.JJD))
'n = n + 1
End If
Else
'Dernier quartier
UneDate.JJD = j - 0.0028 + 0.0004 * Cos(M) + -0.0003 * Cos(Mp)
Correction I
Cle = Phase(I) & ConvertiDateJulienne(CDbl(UneDate.JJD))
If Not MonDico.Exists(Cle) Then
MonDico.Add Key:=Phase(I) & ConvertiDateJulienne(CDbl(UneDate.JJD)), item:=ConvertiDateJulienne(CDbl(UneDate.JJD))
'n = n + 1
'Debug.Print ConvertiDateJulienne(CDbl(Unedate.JJD))
End If
End If
End If
Next
Next
For I = MonDico.Count - 1 To 0 Step -1
If month(Mid(MonDico.keys()(I), 2)) < month(Date) Then
MonDico.Remove MonDico.keys()(I)
End If
Next
End Function
'***********************************************
Sub Algorithme(Annee, Debut, Optional Fin)
'***********************************************
Dim Cle As Variant
Dim item
Dim HeureEte
Dim HeureHiver
Dim I
Dim Tbl()
Dim cell As String
'***********************************************
'On Error GoTo err
MoonPhases Annee:=Annee, Debut:=Debut, Fin:=Fin
ReDim Tbl(0 To MonDico.Count - 1, 1 To 4)
'
For Each Cle In MonDico.keys
item = MonDico.item(Cle)
'
If Year(item) >= 1996 And Year(item) < 2026 Then
HeureEte = HeureEteHiver(Year(item), 3, 31)
HeureHiver = HeureEteHiver(Year(item), 10, 31)
'
ElseIf Year(item) >= 1976 And Year(item) < 1996 Then
HeureEte = HeureEteHiver(Year(item), 3, 31)
HeureHiver = HeureEteHiver(Year(item), 9, 30)
End If
'
If Year(item) >= 1976 Then
'1976
If DateDiff("d", DateSerial(Year(item), month(item), day(item)), HeureEte) < 0 And _
DateDiff("d", DateSerial(Year(item), month(item), day(item)), HeureHiver) > 0 Then
Cle = Cle & "- " & " TU + 2h"
item = DateAdd("h", 2, item)
Else
Cle = Cle & " - " & "TU + 1h"
item = Mid(DateAdd("h", 1, item), 1, Len(item) - 2)
End If
'à partir de 1946 "TU + 1"
ElseIf Year(item) >= 1946 And Year(item) < 1976 Then
Cle = Cle & " - " & "TU + 1h"
item = DateAdd("h", 1, item)
'à partir de 2027 "TU + 1"
ElseIf Year(item) > 2026 Then
'Cle = Cle & " - " & "TU + 1h"
'Item = DateAdd("h", 1, Item)
'sinon "TU "
Else
Cle = Cle & " - " & "TU "
End If
'
Tbl(I, 1) = Mid(Cle, 1, 1)
Tbl(I, 2) = DateSerial(Year(item), month(item), day(item))
Tbl(I, 3) = CDate(item)
Tbl(I, 4) = Trim(Right(Cle, 7))
I = I + 1
Next
'
On Error Resume Next
With Worksheets("Lune").ListObjects("t_Lune")
.DataBodyRange.Delete
.ListRows.Add
.DataBodyRange.Resize(UBound(Tbl, 1), UBound(Tbl, 2)) = Tbl
.ListColumns(1).DataBodyRange.Font.Name = "Wingdings 2"
End With
End Sub
'***********************************************
Function Trunc(X)
'***********************************************
'ceil retourne le plus petit entier supérieur ou égal au nombre donné.
'floor renvoie le plus grand entier qui est inférieur ou égal à un nombre
'if (x>0.0) return(Math.floor(x));
'else return Math.ceil(x)
'***********************************************
If (X > 0#) Then
Trunc = Int(X)
Else
Trunc = Fix(X)
End If
End Function
'***********************************************
Function HeureEteHiver(Annee, mois, jour)
'***********************************************
'COMMENTAIRE: le code ne tient nullement compte des fameux dimanche d'octobre ou mars.. seulement du jour de la semaine....?? ca donne juste le dimanche qui précède la date donnée en paramètre
Dim I
'***********************************************
'Le passage à l’heure d’hiver a lieu le dernier dimanche d’octobre
'Le passage à l’heure d’été le dernier dimanche de mars.
'Hiver UTC +1, ETE UTC +2
For I = 0 To 7
If Weekday(DateAdd("d", -I, DateSerial(Annee, mois, jour))) = 1 Then
HeureEteHiver = DateAdd("d", -I, DateSerial(Annee, mois, jour))
Exit For
End If
Next I
End Function
'***********************************************
Function ConvertiDateJulienne(DateJulienne As Double)
'***********************************************
Dim D As Double
Dim Heures As Double
Dim Minutes As Integer
Dim secondes As Integer
'1 jour = 86400 secondes
'A partir de 1900
'***********************************************
D = (86400 * (DateJulienne - Fix(DateJulienne)))
'
Heures = Int(D / 3600)
Minutes = Int((D - (3600 * Heures)) / 60)
secondes = D - (3600 * Heures) - (60 * Minutes)
'Le jour julien commence à 12H
Heures = (12 + Heures) Mod 24
'
If DateJulienne - Fix(DateJulienne) >= 0.5 Then
DateJulienne = DateJulienne + 1
End If
'
ConvertiDateJulienne = _
DateAdd("d", Fix(DateJulienne) - 2415021, "01/01/1900") & " " & _
IIf(Int(Heures) = 0, "00 : ", Format(Int(Heures), "0# : ")) & _
IIf(Int(Minutes) = 0, "00", Format(Int(Minutes), "0#")) '& _
IIf(Int(Secondes) = 0, "", Format(Int(Secondes), "0#s "))
End Function
'***********************************************
Function JJDATE()
'***********************************************
Dim Z1
Dim Z
Dim A, B, c, D, e
Dim ALPHA
'***********************************************
Z1 = UneDate.JJD + 0.5
Z = Trunc(Z1)
'15/15/1582
'If (Z < 2299161) Then
' A = Z
'Else
ALPHA = Trunc((Z - 1867216.25) / 36524.25)
A = Z + 1 + ALPHA - Trunc(ALPHA / 4)
B = A + 1524
c = Trunc((B - 122.1) / 365.25)
D = Trunc(365.25 * c)
e = Trunc((B - D) / 30.6001)
UneDate.jour = Trunc(B - D - Trunc(30.6001 * e))
'End If
'
If (e < 13.5) Then
UneDate.mois = Trunc(e - 1)
Else
UneDate.mois = Trunc(e - 13)
End If
If (UneDate.mois >= 3) Then
UneDate.An = Trunc(c - 4716)
Else
UneDate.An = Trunc(c - 4715)
End If
End Function
'***********************************************
Function Modulo(D, n)
'***********************************************
'D dividende
'N diviseur
'Equivalent de % en Javacript
Modulo = D - n * Int(D / n)
End Function
'***********************************************
Function Correction(I)
'***********************************************
Dim D
Dim TETUS
Dim TETUJ
'***********************************************
D = oar.CODE1 / 100#
TETUS = 32.23 * (D - 18.3) * (D - 18.3) - 15
TETUJ = TETUS / 86400#
UneDate.JJD = UneDate.JJD + 0.0003472222 'ajout de 30s pour arrondi sur la minute avant troncature lors de l'affichage
UneDate.JJD = UneDate.JJD - TETUJ
'If Unedate.JJD < 2299160.5 Then
' JJDATEJ
' BISJ
'Else
JJDATE
'BISG
'End If
'oar.OK = 0
'
'If (Unedate.Mois = pMOIS) Then oar.OK = 1
'NL
'If i = 0 Then
' If pMOIS > Unedate.Mois Then
' Init_jrl '(pMOIS)
' End If
'Else
' If (Unedate.Mois = 12 And pMOIS = 1) Then Init_jrl (pMOIS)
'End If
End Function
'***********************************************