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
'***********************************************