Calendrier presque perpétuel

[Micoute]

Bonjour à tous, je vous soumet ce calendrier qui a surement besoin d'être peaufiné, mais il est très fonctionnel et on ne peut pas entrer de date non valide comme 31/09/2014 ou 29/02/2014, il va du 01/01/1601 au 31/12/9999, c'est à cause de ces limites qu'il est presque perpétuel.

Code : Tout sélectionner

; Calendrier presque perpétuel

EnableExplicit

Enumeration Fenetres
  #Fenetre_principale
EndEnumeration

Enumeration Gadgets
  #Str_Jour
  #Str_Mois
  #Str_Annee
  #Txt_Jour
  #Txt_Mois
  #Txt_Annee
  #Txt_Resultat
  #Police
  #Police2
EndEnumeration

Global X, Police, Police2, a.s, m.s, j.s, JS.s, Mois.s
Define.i Event, EventWindow, EventGadget

;- Constantes et Globales
#SecsParJour = 86400 ; Secondes par jour
#AnneeEpoque = 1601  ; Première année valable pour la plupart des routines date
#JoursJusqu_a_1970 = 134774 ; Jours à compter de la première journée de l'année époque (01-Jan-1601) au 01-Jan-1970
Global ML_Unite_Date.q = 10000000 ; granularité, initialement 1 seconde pour la compatibilité avec les routines date de PB 4.xx
Global ML_Unite_Jour.q = 10000000 * #SecsParJour / ML_Unite_Date ; granularité nombre d'unités par jour

Procedure.q ML_Date(Annee = 0, Mois = 0, Jour = 0, Heure = 0, Minute = 0, Seconde = 0)
  ; Retourne une date/heure du calendrier julien donnée d'une date/heure du calendrier grégorien
  ; Retourne la date Julienne/heure locale pour aujourd'hui, si aucun argument n'est donné
  ; Retourne -1 si l'année est hors de portée
  Protected date.q, hs.SYSTEMTIME
  If Annee | Mois | Jour | Heure | Minute | Seconde = 0
    GetLocalTime_(@hs) ; Heure locale
  Else
    If Annee = 0 ; Si seulement l'heure est spécifiée
      Annee  = #AnneeEpoque
      Mois   = 1
      Jour   = 1
    ElseIf Annee < #AnneeEpoque Or Annee > 9999
      ProcedureReturn -1
    Else
      If Mois = 0
        Mois  = 1
      EndIf
      If Jour = 0
        Jour  = 1
      EndIf
    EndIf
    With hs
      \wYear   = Annee
      \wMonth  = Mois
      \wDay    = Jour
      \wHour   = Heure
      \wMinute = Minute
      \wSecond = Seconde
    EndWith
  EndIf
  SystemTimeToFileTime_(@hs, @date) ; Heure locale
  ProcedureReturn (date + ML_Unite_Date / 2) / ML_Unite_Date
EndProcedure

Procedure.q ML_Aujourd_hui()
  ; Retourne la date julienne pour minuit au début d'aujourd'hui
  ProcedureReturn ML_Date() / ML_Unite_Jour * ML_Unite_Jour
EndProcedure

Procedure.i ML_Jds(date.q = -1)
  ; Retourne le jour de la semaine en nombre:
  ; 0=Dim  1=Lun  2=Mar  3=Mer  4=Jeu  5=Ven  6=Sam
  ; S'il n'y a pas d'argument, le jour courant est renvoyé
  If date < 0
    date = ML_Date()
  EndIf ; Aujourd'hui
  ProcedureReturn Mod((date / ML_Unite_Jour + 1), 7) ; Comme 01-Jan-1601 C'était un lundi
EndProcedure

ProcedureDLL ML_Amj(date.q, *Annee, *Mois, *Jour, *Heure=0, *Minute=0, *Seconde=0)
  ; Retourne (dans les arguments) une date du calendrier grégorien donnée, en une date julienne
  ; Si la date est négative, la date/heure locale pour ML_Aujourd_hui() est retournée
  ; si la date est trop grande, le dernier instant de l'année 9999 est retourné
  ; L'inverse de la routine ML_Date()
  Protected datemax.q = 2650467743999999999 ; 31/12/9999
  Protected hs.SYSTEMTIME
  If date < 0 ; Supposons maintenant
    GetLocalTime_(@hs)
  Else
    date * ML_Unite_Date
    If date > datemax
      date = datemax
    EndIf
    FileTimeToSystemTime_(@date, @hs)
  EndIf
  With hs
    PokeI(*Annee, \wYear)
    PokeI(*Mois, \wMonth)
    PokeI(*Jour, \wDay)
    If *Heure
      PokeI(*Heure, \wHour)
    EndIf
    If *Minute
      PokeI(*Minute, \wMinute)
    EndIf
    If *Seconde
      PokeI(*Seconde, \wSecond)
    EndIf
  EndWith
EndProcedure

ProcedureDLL.i ML_Annee(date.q = -1)
  ; Retourne la valeur de l'année (#AnneeEpoque..9999) de la date donnée
  ; S'il n'y a aucun argument, l'année en cours est retournée
  Protected a, m, j
  ML_Amj(date, @a, @m, @j)
  ProcedureReturn a
EndProcedure

ProcedureDLL.i ML_Mois(date.q = -1)
  ; Renvoie le mois (1 .. 12) dans l'année pour la date donnée
  ; S'il n'y a aucun argument, le mois en cours est retourné
  Protected a, m, j
  ML_Amj(date, @a, @m, @j)
  ProcedureReturn m
EndProcedure

ProcedureDLL.b ML_Bissextile(Annee = -1)
; Retourne Vrai si l'année est une année bissextile (366 jours)
; S'il n'y a aucun argument, l'année en cours est utilisée
;   Dans le calendrier grégorien, l'année bissextile est
;   toute année divisible par 4, sauf
;   année du centenaire non divisible par 400
; L'année équinoxe de printemps est d'environ 365.242374 jours longs (et croissants)
If Annee <= 0
  Annee = ML_Annee()
EndIf ; Cette année
If (Mod(Annee, 4) = 0 And Mod(Annee, 100) <> 0) Or (Mod(Annee, 400) = 0)
  ProcedureReturn #True
EndIf
ProcedureReturn #False
EndProcedure

ProcedureDLL.i ML_JoursDansMois(Annee = -1, Mois = -1)
  ; Retourne le nombre de jours dans le mois donné (28 .. 31)
  ; Si l'année est absente, l'année en cours est utilisée
  ; Si l'année est présente, mais le mois absent, février est utilisé
  ; Si l'année et le mois sont tous deux absents, le mois courant de l'année en cours est utilisé
  Protected Jours
  If Annee <= 0
    Annee = ML_Annee()
    If Mois <= 0
      Mois = ML_Mois()
    EndIf
  Else
    If Mois <= 0
      Mois = 2
    EndIf
  EndIf
  If Mois = 2
    Jours = 28 + ML_Bissextile(Annee)
  Else
    Jours = 31 - $A55 >> Mois & 1
  EndIf
  ProcedureReturn Jours
EndProcedure

Procedure.s ML_Jds_(date.q = -1)
  ;Retourne le jour de la semaine en texte:
  ; 0 = dimanche, 1 = lundi, ... , 6 = samedi
  ; S'il n'y a pas d'argument, le jour courant est renvoyé
  
  If date < 0
    date = ML_Date()
  EndIf ; Aujourd'hui
  
  Js = StringField("dimanche,lundi,mardi,mercredi,jeudi,vendredi,samedi", ML_Jds(ML_Date(Val(a), Val(m), Val(j)))+1,",")
  
  ProcedureReturn Js
  
EndProcedure

Procedure.s ML_Mois_(date.q=-1)
  ; Renvoie le mois (1 .. 12) dans l'année pour la date donnée
  
  If date < 0
    date = ML_Date()
  EndIf ; Aujourd'hui
  
  Select date
    Case 1
      Mois = "Janvier"
    Case 2
      Mois = "Février"
    Case 3
      Mois = "Mars"
    Case 4
      Mois = "Avril"
    Case 5
      Mois = "Mai"
    Case 6
      Mois = "Juin"
    Case 7
      Mois = "Juillet"
    Case 8
      Mois = "Août"
    Case 9
      Mois = "Septembre"
    Case 10
      Mois = "Octobre"
    Case 11
      Mois = "Novembre"
    Case 12
      Mois = "Décembre"
  EndSelect 
  
  ProcedureReturn Mois
EndProcedure

Procedure Clic_Jour()
  If Val(GetGadgetText(#Str_Jour)) > ML_JoursDansMois(Val(GetGadgetText(#Str_Annee)),Val(GetGadgetText(#Str_Mois)))
    SetGadgetText(#Str_Jour, "")
    SetGadgetText(#Txt_Resultat, "Date non valide")
  EndIf
EndProcedure  
  
Procedure Ouvrir_Fenetre_principale()
  OpenWindow(#Fenetre_principale, #PB_Ignore, #PB_Ignore, 470, 200, "Calendrier perpétuel 01/01/1601 -> 31/12/9999",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)

  TextGadget(#Txt_Jour, 5, 10, 70, 40, "Jour")
  StringGadget(#Str_Jour, 80, 10, 50, 40, "")
  TextGadget(#Txt_Mois, 130, 10, 80, 40, "Mois")
  StringGadget(#Str_Mois, 210, 10, 50, 40, "")
  TextGadget(#Txt_Annee, 260, 10, 100, 40, "Année")
  StringGadget(#Str_Annee, 360, 10, 100, 40, "")
  TextGadget(#Txt_Resultat, 10, 100, 440, 80, "")
  
  BindGadgetEvent(#Str_Jour,@Clic_Jour())
  
  Police = LoadFont(#Police, "DejaVu Sans Mono", 24, #PB_Font_Bold)
  For X = #Str_Jour To #Txt_Annee
    SetGadgetFont(X, Police)
  Next
  Police2 = LoadFont(#Police2, "DejaVu Sans Mono", 12, #PB_Font_Bold)
  SetGadgetFont(#Txt_Resultat, Police2) 
  
  
  SendMessage_(GadgetID(#Str_Jour), #EM_SETLIMITTEXT, 2, 0) ; seulement 2 chiffres pour le jour
  SendMessage_(GadgetID(#Str_Mois), #EM_SETLIMITTEXT, 2, 0) ; Idem pour le mois
  SendMessage_(GadgetID(#Str_Annee), #EM_SETLIMITTEXT, 4, 0) ; limité à 4 chiffres pour l'année
  
  SetActiveGadget(#Str_Annee) 
EndProcedure

Ouvrir_Fenetre_principale()


;- Boucle principale
Repeat
  Event = WaitWindowEvent()
  Select Event
      ; +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    Case #PB_Event_Gadget
      EventGadget = EventGadget()
      
      If Len(GetGadgetText(#Str_Annee)) = 4  And EventType() = #PB_EventType_Change
        SetActiveGadget(#Str_Mois)
      EndIf
      
      If Len(GetGadgetText(#Str_Mois)) = 2 And EventType() = #PB_EventType_Change
        SetActiveGadget(#Str_Jour)
      EndIf
      
      a = GetGadgetText(#Str_Annee)
      m = GetGadgetText(#Str_Mois)
      j = GetGadgetText(#Str_Jour)
      
      ML_Jds_()

      ML_Mois_(Val(m))
      
      If GetGadgetText(#Str_Jour) <> "" And GetGadgetText(#Str_Mois) <> "" And Val(GetGadgetText(#Str_Annee)) > 1600
        If ML_Date(Val(a), Val(m), Val(j)) < ML_Aujourd_hui()
          SetGadgetText(#Txt_Resultat, "le "+j+" "+Mois+" "+a+" était un "+Js)
        ElseIf Val(GetGadgetText(#Str_Jour)) = Day(Date()) And 
               Val(GetGadgetText(#Str_Mois)) = Month(Date()) And 
               Val(GetGadgetText(#Str_Annee)) = Year(Date())
          SetGadgetText(#Txt_Resultat, "le "+j+" "+Mois+" "+a+" est un "+Js)
        Else
          SetGadgetText(#Txt_Resultat, "le "+j+" "+Mois+" "+a+" sera un "+Js)
        EndIf  
      EndIf
      
    Case #PB_Event_CloseWindow
      EventWindow = EventWindow()
      If EventWindow = #Fenetre_principale
        CloseWindow(#Fenetre_principale)
        Break
      EndIf
  EndSelect
ForEver
End

[majikeyric]

En l'an 3500 je feterai mon anniversaire un jeudi.
C'est bon à savoir

[Micoute]

Bonjour majikeyric, je vois que comme moi, tu aimes bien savoir les renseignements qui ne servent à rien, sinon à le savoir !

En 3500, il y aura plusieurs jeudis et ça sera un de ceux-là !

[beruska]

Déjà fait en 2011, vraiment perpétuel

Code : Tout sélectionner

; Calcul du Jour Julien et du jour de la semaine correspondant, à partir d'une date donnée.
; les dates doivent toujours figurer en format JJ MM AAAA avec espaces ou séparateurs.
; en PB_51 by beruska

Procedure.s datecomplete(date$)
  
  jour$ = "Dimanche,Lundi,Mardi,Mercredi,Jeudi,Vendredi,Samedi"
  mois$ = "janvier,février,mars,avril,mai,juin,juillet,août,septembre,octobre,novembre,décembre"
  
  j = Val(Left(date$,2))
  m = Val(Mid(date$,4,2)): mm = m                 ; on conserve le valeurs d'origine (mm et yy)
  y = Val(Right(date$,4)): yy = y
    
    A0.f = y + m/100 + j/10000                    ; préparation de la date 15/10/1582
    A0 = Int(A0*10000+0.5)/10000                  ; sous la forme 1582.1015
  
  If m < 3                                        ; on commence toujours les calculs le 1er mars
      m+12                                        ; donc janvier et février sont les mois 13 et 14
      y-1                                         ; de l'année précedente
    EndIf

  If A0 > 1582.1004 And A0 < 1582.1015            ; le lendemain du 04/10/1582 est le 15/10/1582
  MessageRequester("Error", "Date inexistante")   ; donc éliminons les dates inexistantes (du 5 au 14)
  Goto iniz                                      ; on recommence
  EndIf
  
  ; -------------------------
  ; algorithme du jour julien
  ; -------------------------
  a = Int(y/100)
  If A0 < 1582.1015 
  b = 0                                           ; pour les dates du calendrier julien
  Else
  b = 2-a+Int(a/4)                               ; pour les dates du calendrier grégorien
  EndIf
  c = Int(365.25 * y)
  d = Int(30.6001 * (m+1))
  
  jj.f = b + c + d + j + 1720994.5                ; jj est le jour julien de la date choisie
  
  Debug "Jour Julien = " + StrF(jj,2)   ; [activer cette ligne pour voir le numéro du jour julien]
  
  ; calcul du jour de la semaine
  e = jj + 1.5                                    
  jour = (e % 7) + 1
  g$ = StringField(jour$,jour,",")
  date$ = g$ + " " + Str(j) + " " + StringField (mois$, mm, ",") + " " + Str(yy)
  
  ProcedureReturn 

EndProcedure

; -------
; EXEMPLE
; -------

Global jj.f

iniz:
choix$ = InputRequester("Jour de la semaine", "Insérer date (JJ/MM/AAAA)","")
Debug datecomplete(choix$)
; ----------------
; 
; la bataille de Marignan a eu lieu les 13 et 14 septembre 1515 (Wikipedia dit un jeudi et un vendredi)
; vérifier avec le prg

[Micoute]

Bonjour beruska,

oh oui, il est vraiment beaucoup moins limité que le mien, il n'y a qu'un problème de label que j'ai vite résolu en le commentant.

[Ar-S]

Petite modif pour virer le goto et afficher les 2 données par défaut.

Code : Tout sélectionner

; Calcul du Jour Julien et du jour de la semaine correspondant, à partir d'une date donnée.
; les dates doivent toujours figurer en format JJ MM AAAA avec espaces ou séparateurs.
; en PB_51 by beruska => petite modif Ar-S compatible 5.30 (et sans goto)

Procedure.s datecomplete(date$)
 
  jour$ = "Dimanche,Lundi,Mardi,Mercredi,Jeudi,Vendredi,Samedi"
  mois$ = "janvier,février,mars,avril,mai,juin,juillet,août,septembre,octobre,novembre,décembre"
 
  j = Val(Left(date$,2))
  m = Val(Mid(date$,4,2)): mm = m                 ; on conserve le valeurs d'origine (mm et yy)
  y = Val(Right(date$,4)): yy = y
   
    A0.f = y + m/100 + j/10000                    ; préparation de la date 15/10/1582
    A0 = Int(A0*10000+0.5)/10000                  ; sous la forme 1582.1015
 
  If m < 3                                        ; on commence toujours les calculs le 1er mars
      m+12                                        ; donc janvier et février sont les mois 13 et 14
      y-1                                         ; de l'année précedente
    EndIf

  If A0 > 1582.1004 And A0 < 1582.1015            ; le lendemain du 04/10/1582 est le 15/10/1582
     						; donc éliminons les dates inexistantes (du 5 au 14)
  	ProcedureReturn "Erreur"                            ; on recommence
  Else
  	 ; -------------------------
  ; algorithme du jour julien
  ; -------------------------
  a = Int(y/100)
  If A0 < 1582.1015
  b = 0                                           ; pour les dates du calendrier julien
  Else
  b = 2-a+Int(a/4)                               ; pour les dates du calendrier grégorien
  EndIf
  c = Int(365.25 * y)
  d = Int(30.6001 * (m+1))
 
  jj.f = b + c + d + j + 1720994.5                ; jj est le jour julien de la date choisie
 
  Julien$ = "Jour Julien = " + StrF(jj,2) +Chr(10)   ; [activer cette ligne pour voir le numéro du jour julien]
 
  ; calcul du jour de la semaine
  e = jj + 1.5                                   
  jour = (e % 7) + 1
  g$ = StringField(jour$,jour,",")
  date$ = g$ + " " + Str(j) + " " + StringField (mois$, mm, ",") + " " + Str(yy)
 
  ProcedureReturn Julien$ + Date$
  
  EndIf
 
 

EndProcedure

; -------
; EXEMPLE
; -------

Global jj.f

choix$ = InputRequester("Jour de la semaine", "Insérer date (JJ/MM/AAAA)","")
Resultat$ = datecomplete(choix$)
If  Resultat$ = "Erreur"
	MessageRequester("Error", "Date inexistante")    
Else
	Debug Resultat$
EndIf	

; ----------------
;
; la bataille de Marignan a eu lieu les 13 et 14 septembre 1515 (Wikipedia dit un jeudi et un vendredi)
; vérifier avec le prg