Option Explicit
Function AnalyserDate(AAnneeR As Integer, AMoisR As Integer, AJourR As Integer) As String
Dim strDateG As String
Dim intAnnee As Integer, intMois As Integer, intJour As Integer
Dim lngJourBasic As Long
Const JourBasicOffset = -39545 'Valeur magique calculée pour faire correspondre 1er vendémiaire an I et 22/9/1792
Const JoursPar4ans = 1461
Const JoursParMois = 30
' Vérifications au départ : On n'accepte que les années entre 1 et 14.
' Selon Wikipedia, il n'y aurait pas consensus sur la détermination (virtuelle) des années "sextiles"
' (avec 6 jours complémentaires) si le calendrier avait été utilisé au delà de l'an 14.
If (AAnneeR < 1) Or (AAnneeR > 14) Then
strDateG = "Date hors champ de conversion"
ElseIf (AMoisR < 1) Or (AMoisR > 13) Then
' On notera que les jours complémentaires sont affectés à un mois fictif. Pas de vérif des années "sextiles"
ElseIf (AJourR < 1) Or (AJourR > 30) Or ((AJourR > 6) And (13 = AMoisR)) Then
Else
' A partir d'ici, j'applique la formule magique de Monsieur Scott E Lee
lngJourBasic = Int((AAnneeR * JoursPar4ans) / 4) + (AMoisR - 1) * JoursParMois + AJourR + JourBasicOffset
intAnnee = Year(lngJourBasic)
intMois = Month(lngJourBasic)
intJour = Day(lngJourBasic)
strDateG = Format(intJour, "00") & "/" & Format(intMois, "00") & "/" & Format(intAnnee, "0000")
End If
AnalyserDate = strDateG
End Function
Private Function NumeroMois(ByVal ANomMoisR As String, ByRef ARepublicain As Boolean) As Integer
Dim intRangMoisR As Integer
Dim strNomMoisR As String
Select Case UCase(Left$(Trim(ANomMoisR), 4))
Case "VEND", "VD", "JANV", "JAN", "JANU"
intRangMoisR = 1
Case "BRUM", "BR", "FEV", "FEB", "FEVR", UCase("FéVR"), "FEBR"
intRangMoisR = 2
Case "FRIM", "FRI", "MARS", "MAR", "MARC", "MA"
intRangMoisR = 3
Case "NIVO", "NIV", UCase("NIVô"), "NI", "AVRI", "AVR", "APR", "APRI"
intRangMoisR = 4
Case "PLUV", "PLU", "PL", "MAI", "MAY"
intRangMoisR = 5
Case "VENT", "VEN", "VE", "JUIN", "JUN", "JUNE"
intRangMoisR = 6
Case "GERM", "GE", "JUIL", "JULY", "JUL"
intRangMoisR = 7
Case "FLOR", "FLO", "FL", "AOUT", "AOU", "AUG", "AOÛT"
intRangMoisR = 8
Case "PRAI", "PRA", "PR", "SEPT", "SEP"
intRangMoisR = 9
Case "MESS", "MES", "ME", "OCTO", "OCT"
intRangMoisR = 10
Case "THER", "THE", "TH", "NOV", "NOVE"
intRangMoisR = 11
Case "FRUC", "FRU", "FR", "DEC", "DECE", UCase("DéCE")
intRangMoisR = 12
Case "COMP", "CO"
intRangMoisR = 13
Case Else
intRangMoisR = 0
End Select
Select Case UCase(Left$(Trim(ANomMoisR), 1))
Case "V", "B", "G", "P", "T", "C"
ARepublicain = True
Case Else
Select Case UCase(Left$(Trim(ANomMoisR), 2))
Case "NI", "ME", "FR", "FL"
ARepublicain = True
Case Else
ARepublicain = False
End Select
End Select
NumeroMois = intRangMoisR
End Function
' Code modifié par BrunoM45
Public Function DateRepublicaine(AChaineDate As String) As String
Dim strSeparateur As String
Dim sDateDeb As String, sAnnée As String, sTmp As String
Dim IndAn As Integer, TabAn As Variant
Dim varContenuDate As Variant
Dim intContenu As Integer
Dim intMoisR As Integer
Dim intJourR As Integer
Dim intAnneeR As Integer
Dim blnRepublicain As Boolean
Dim strMois As String
' Recalcul auto
Application.Volatile
'Quel est le séparateur
strSeparateur = ChercherSeparateur(AChaineDate)
'Découper la date en éléments séparés
varContenuDate = Split(AChaineDate, strSeparateur)
'Combien d'éléments ?
intContenu = UBound(varContenuDate)
If intContenu = 2 Then
If IsNumeric(varContenuDate(1)) Then
intMoisR = CInt(varContenuDate(1))
Else
intMoisR = NumeroMois(CStr(varContenuDate(1)), blnRepublicain)
End If
If IsNumeric(varContenuDate(2)) Then intAnneeR = CInt(varContenuDate(2))
Else
intMoisR = NumeroMois(CStr(varContenuDate(1)), blnRepublicain)
If IsNumeric(varContenuDate(3)) Then
intAnneeR = CInt(varContenuDate(3))
Else
TabAn = Split("I,II,III,IV,V,VI,VII,VIII,IX,X,XI,XII,XIII,XIV", ",")
IndAn = 0
Do While TabAn(IndAn) <> varContenuDate(3)
IndAn = IndAn + 1
Loop
intAnneeR = IndAn + 1
End If
End If
If IsNumeric(varContenuDate(0)) Then intJourR = CInt(varContenuDate(0))
If blnRepublicain Then
DateRepublicaine = AnalyserDate(intAnneeR, intMoisR, intJourR)
Else
DateRepublicaine = Format(intAnneeR, "0000") & "/" & Format(intMoisR, "00") & "/" & Format(intJourR, "00")
End If
End Function
Private Function ChercherSeparateur(AChaineDate As String) As String
If InStr(1, AChaineDate, "/") > 0 Then
ChercherSeparateur = "/"
ElseIf InStr(1, AChaineDate, "-") > 0 Then
ChercherSeparateur = "-"
ElseIf InStr(1, AChaineDate, " ") > 0 Then
ChercherSeparateur = " "
ElseIf InStr(1, AChaineDate, ".") > 0 Then
ChercherSeparateur = "."
ElseIf InStr(1, AChaineDate, "_") > 0 Then
ChercherSeparateur = "_"
End If
End Function