PureBasic

Comme promis voici la partie calendrier.
La base de ce programme est l'utilisation " peut-être abusive" de l'indexation des gadgets dans Enumération. mais ceci a permis de ne pas utiliser les API. donc en principe utilisable par tous les OS.
Ce programme est certainement améliorable. N' hésitez pas

Je n'ai programmé que les fêtes fixes, a vous les fêtes a dates aléatoires.

Vous pouvez en faire ce que vous voulez

Code : Tout sélectionner

;====== MLD ===
;=== 8/2/2012 =
;=== PB 4.61 ==
;==============

Enumeration 1 ; cal jour
#fenagd = 1
#btJm1 = 2
#btJp1 = 3
#btajd = 4
#text1 = 5
#text2 = 6
#text3 = 7
#text4 = 8

#txtj1 = 10
#txtj2 = 11
#txtj3 = 12
#txtj4 = 13
#txtj5 = 14
#txtj6 = 15
#txtj7 = 16
#txtj8 = 17
#txtj9 = 18
#txtj10 = 19
#txtj11 = 20
#txtj12 = 21
#txtj13 = 22
#txtj14 = 23
#txtj15 = 24
#txtj16 = 25
#txtj17 = 26
#txtj18 = 27
#txtj19 = 28
#txtj20 = 29
#txtj21 = 30
#txtj22 = 31
#txtj23 = 32
#txtj24 = 33
#txtj25 = 34
#txtj26 = 35
#txtj27 = 36
#txtj28 = 37
#txtj29 = 38
#txtj30 = 39
#txtj31 = 40
#txtj32 = 41
#txtj33 = 42
#txtj34 = 43
#txtj35 = 44
#txtj36 = 45
#txtj37 = 46
#txtj38 = 47
#txtj39 = 48
#txtj40 = 49
#txtj41 = 50
#txtj42 = 51

#txtj43 = 60
#txtj44 = 61
#txtj45 = 62
#txtj46 = 63
#txtj47 = 64
#txtj48 = 65
#txtj49 = 66
#txtj50 = 67
#txtj51 = 68
#txtj52 = 69
#txtj53 = 70
#txtj54 = 71
#txtj55 = 72
#txtj56 = 73
#txtj57 = 74
#txtj58 = 75
#txtj59 = 76
#txtj60 = 77
#txtj61 = 78
#txtj62 = 79
#txtj63 = 80
#txtj64 = 81
#txtj65 = 82
#txtj66 = 83
#txtj67 = 84
#txtj68 = 85
#txtj69 = 86
#txtj70 = 87
#txtj71 = 88
#txtj72 = 89
#txtj73 = 90
#txtj74 = 91
#txtj75 = 92
#txtj76 = 93
#txtj77 = 94
#txtj78 = 88
#txtj79 = 89
#txtj80 = 90
#txtj81 = 91
#txtj82 = 92
#txtj83 = 93
#txtj84 = 94
#txtj85 = 95
#txtj86 = 96
#txtj87 = 97
#txtj88 = 98
#txtj89 = 99
#txtj90 = 100
#txtj91 = 101

#txtm = 102
EndEnumeration
Enumeration 2 ;jours de la semaine + mois
#txtjs1 = 111
#txtjs2 = 112
#txtjs3 = 113
#txtjs4 = 114
#txtjs5 = 115
#txtjs6 = 116
#txtjs7 = 117
#txtjs8 = 118

#txt2js1 = 120
#txt2js2 = 121
#txt2js3 = 122
#txt2js4 = 123
#txt2js5 = 124
#txt2js6 = 125
#txt2js7 = 126
#txt2m = 128
EndEnumeration
Global FontID1 = LoadFont(1,"MS san serif",18 ,#PB_Font_HighQuality)
Global FontID2 = LoadFont(2,"MS san serif",32 ,#PB_Font_HighQuality)
Global tdate$
Declare affcal(tdate$,ind.b)

Procedure bissextile(annee) 
    If (annee % 4 = 0 And annee % 100 <> 0) Or annee % 400 = 0
        bissextile= #True
    Else
        bissextile = #False
    EndIf
    ProcedureReturn bissextile
EndProcedure 

Procedure Ffix(j,m)
Dt$ = Str(j) + "/" + Str(m)
Select Dt$
 Case "1/1" ;1er janvier
  indf.B = 1 
 Case "1/5" ;1er mai
  indf.B = 1
 Case "8/5" ;8 mai
  indf.B = 1
 Case "14/7" ;14 juillet
  indf.B = 1 
 Case "15/8" ;15 aout
  indf.B = 1 
 Case "1/11" ;1 Novembre
  indf.B = 1
 Case "11/11" ;11 novembre
  indf.B = 1 
 Case "25/12" ;25 décembre
  indf.B = 1
 Default
  indf.B = 0
EndSelect
ProcedureReturn indf.B         
EndProcedure

Procedure.s calculnumjour(an,mois,jour,z1,z2,z3);calcul le nombre de jour écoulé a la date indiqué et ce qui reste
;======= calcul jour ==========
 If bissextile(an) = 1
  totalj.w = 366
 Else
  totalj.w = 365
 EndIf
nbjt.w = DayOfYear(Date(an, mois, jour, 0, 0, 0))
diffjour.w = totalj - nbjt.w  
;======= calcul num semaine =====
Weeknum=0
For i=1 To DayOfYear(Date(an, mois, jour, 0, 0, 0))
 day_of_week=DayOfWeek(AddDate( Date(Year(Date()),01,01,1,1,1), #PB_Date_Day , i-1))
 If day_of_week= 1 And i <> 1 
   Weeknum=Weeknum+1
 EndIf
Next i
ProcedureReturn "Semaine: " + Str(Weeknum) + "     " + "Jour: " + Str(nbjt.w) + "/" + Str(totalj) + "-" +  Str(diffjour)
EndProcedure

Procedure calculnbjm(an,mois,jour,z1,z2,z3)
Select mois  
 Case 1,3,5,7,8,10,12 ; calcul le nombre de jours par mois
  nbjpm.w = 31
 Case 2
  If bissextile(an) = 1 ; tien compte des années bissextiles
   nbjpm.w = 29
  Else
   nbjpm.w = 28
  EndIf  
 Case 4,6,9,11
  nbjpm.w = 30
EndSelect
ProcedureReturn  nbjpm.w
EndProcedure

Procedure cal()
; ============ cal gauche================
posh = 20
poshl = 21
posv = 50
posvh = 16
posjs = 34
posD.w = 0
For x = 10 To 51
 posD = posD +1
 Select x
  Case 11 To 16 ,18 To 23 ,25 To 30,32 To 37, 39 To 44,46 To 51
   posh = posh + poshl 
 EndSelect
 If x = 17 Or x = 24 Or x = 31 Or x = 38 Or x = 45
  posv = posv + posvh
  posh = 20
 EndIf  
 TextGadget(x,posh,posv,20,15,"",#PB_Text_Center)
 SetGadgetColor(x, #PB_Gadget_BackColor,$CDB69F)
 If posD.w = 7
  SetGadgetColor(x, #PB_Gadget_FrontColor,$0000FF)
  posD.w = 0
 EndIf  
Next
posh = 20
For y= 1 To 7
 numsem$ = StringField("Lu,Ma,Me,Je,Ve,Sa,Di",y,",")
 TextGadget(y +110,posh,posjs,20,15,numsem$,#PB_Text_Center)
 SetGadgetColor(y +110, #PB_Gadget_BackColor,$FFE1CA)
 posh = posh + poshl              
Next
TextGadget(102,20,posjs-16,140,15,"",#PB_Text_Center)
; ================ cal droit =====================
posh = 340
poshl = 21
posv = 50
posvh = 16
posjs = 34
posD = 0
For x = 60 To 101
 posD = posD +1
 Select x
  Case 61 To 66 ,68 To 73 ,75 To 80,82 To 87, 89 To 94, 96 To 101;place les textgad
   posh = posh + poshl 
 EndSelect
 If x = 67 Or x = 74 Or x = 81 Or x = 88 Or x = 95;1er textgad de la ligne
  posv = posv + posvh
  posh = 340
 EndIf  
 TextGadget(x,posh,posv,20,15,"",#PB_Text_Center)
 SetGadgetColor(x, #PB_Gadget_BackColor,$CDB69F)
 If posD.w = 7
  SetGadgetColor(x, #PB_Gadget_FrontColor,$0000FF); color les dimanches
  posD.w = 0
 EndIf   
Next
posh = 340
For y= 1 To 7
 numsem$ = StringField("Lu,Ma,Me,Je,Ve,Sa,Di",y,",");inscrit les jours
 TextGadget(y +120,posh,posjs,20,15,numsem$,#PB_Text_Center)
 SetGadgetColor(y +120, #PB_Gadget_BackColor,$FFE1CA)
 posh = posh + poshl              
Next
TextGadget(128,340,posjs-16,140,15,"",#PB_Text_Center);mois
EndProcedure

Procedure affcal(tdate$,ind.b)
jour.w = Val(Left(tdate$,2));transforme la date en chiffres
mois.w = Val(Mid(tdate$,3,2))
an.w = Val(Right(tdate$,4))
Moisl$ = "JANVIER,FEVRIER,MARS,AVRIL,MAI,JUIN,JUILLET,AOUT,SEPTEMBRE,OCTOBRE,NOVEMBRE,DECEMBRE" 
Jourl$ = "Dimanche,Lundi,Mardi,Mercredi,Jeudi,Vendredi,Samedi" 
For x = 10 To 51
 SetGadgetText(x,"");raz des textgad et couleurs
 SetGadgetColor(x,#PB_Gadget_FrontColor,$0)
Next
For xa = 16 To 51 Step 7
 SetGadgetColor(xa,#PB_Gadget_FrontColor,$0000FF)
Next
If ind.b = 1
 For xx = 60 To 101
  SetGadgetText(xx,"")
  SetGadgetColor(xx,#PB_Gadget_FrontColor,$0) 
 Next
  For xb = 66 To 101 Step 7
  SetGadgetColor(xb,#PB_Gadget_FrontColor,$0000FF)
 Next
EndIf   
;=========== affiche cal gauche ===========
premjour.w = DayOfWeek(Date(an,mois,1,0,0,0));Calcul le 1er jour du mois
If premjour.w = 0 :premjour.w  = 7 :EndIf ; pour le placement donne le num 7 au dimanche au lieu de 0
nbjpm.w = calculnbjm(an,mois,jour,0,0,0)
jm = 0
For j = 10 + (premjour.w -1)  To (10 + nbjpm.w + (premjour.w-1))-1; remplis les textgads en tenant compte du 
 jm = jm +1                ; premier jour du mois
 SetGadgetText(j,Str(jm))
 If Ffix(jm,mois) = 1
  SetGadgetColor(J,#PB_Gadget_FrontColor,$0000FF)
 EndIf  
Next
numois.w = Month(Date(an,mois,jour,0,0,0))
SetGadgetText(102,StringField(Moisl$,numois.w,",")+ " " + Str(an))
TextGadget(5,185,15,135,30,StringField(Jourl$,DayOfWeek(Date(an,mois,jour,0,0,0))+1,","),#PB_Text_Center)
SetGadgetFont(5, FontID(1))
TextGadget(6,185,50,135,40,Str(jour),#PB_Text_Center)
SetGadgetFont(6, FontID(2))
SetGadgetColor(6, #PB_Gadget_FrontColor,$0045FF)  
TextGadget(7,180,100,145,25,StringField(Moisl$,numois.w,","),#PB_Text_Center)
SetGadgetFont(7, FontID(1))
Static empljour.w
Static colorbase  
If empljour.w <> 0
 SetGadgetColor(empljour.w,#PB_Gadget_FrontColor,colorbase)
EndIf
empljour.w = (10 + premjour.w + jour) -2
colorbase = GetGadgetColor(empljour.w,#PB_Gadget_FrontColor)
SetGadgetColor(empljour,#PB_Gadget_FrontColor,$00FFFF)
TextGadget(8,170,130,160,17,calculnumjour(an,mois,jour,0,0,0),#PB_Text_Center)
SetGadgetColor(8,#PB_Gadget_FrontColor,$858585)
calculnumjour(an,mois,jour,0,0,0)
;============ affiche cal droit ===============
;attention si cal gauche est a 12 mois rectifier la date
If ind = 1
 If mois.w = 12
  jour.w = Val(Left(tdate$,2))
  mois.w = 0 
  an.w = an.w + 1 
 EndIf
  premjour2.w = DayOfWeek(Date(an,mois+1,1,0,0,0))
 If premjour2.w = 0 :premjour2.w = 7 :EndIf 
 mois = mois +1
 nbjpm2.w = calculnbjm(an,mois,jour,0,0,0); **************************
 jmd = 0
 For jd = 60 + (premjour2.w-1) To (60 + nbjpm2.w + (premjour2.w-1))-1
  jmd = jmd +1 
  SetGadgetText(jd,Str(jmd)) 
  If Ffix(jmd,mois) = 1
  SetGadgetColor(Jd,#PB_Gadget_FrontColor,$0000FF)
 EndIf 
 Next
 numois2.w = Month(Date(an,mois,1,0,0,0))
 SetGadgetText(128,StringField(Moisl$,numois2.w,",")+ " " + Str(an))
EndIf
EndProcedure
OpenWindow(1, 0, 0, 500, 300, "Début d'héphéméride", #PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget)
cal()
tdate$ = FormatDate("%dd%mm%yyyy",Date())
affcal(tdate$,1)
ButtonGadget(2,200, 250,40,30,Chr(60))
ButtonGadget(4,240, 250,40,30,Chr(60)+ Chr(62))
ButtonGadget(3,280, 250,40,30,Chr(62))
Repeat
   Event = WaitWindowEvent()

   Select Event
      Case #PB_Event_Menu
      Select EventMenu() ; Menus

      EndSelect

      Case #PB_Event_Gadget
       Select EventGadget() ; Gadgets
        Case 2
        ind.b = 0
         jour.w = Val(Left(tdate$,2));transforme la date en chiffres
         mois.w = Val(Mid(tdate$,3,2))
         an.w = Val(Right(tdate$,4))
         jour = jour -1
         If jour = 0
           ind.b = 1 
           mois = mois - 1 : jour = calculnbjm(an,mois,1,0,0,0)
          If mois = 0 
           mois = 12
           an = an -1 
           jour = calculnbjm(an,mois,1,0,0,0)
          EndIf 
         EndIf
         tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0)) 
         affcal(tdate$,ind.b)     
        Case 3
        ind = 0
         jour.w = Val(Left(tdate$,2));transforme la date en chiffres
         mois.w = Val(Mid(tdate$,3,2))
         an.w = Val(Right(tdate$,4))
         nbjpm.w = calculnbjm(an,mois,jour,0,0,0)
         jour = jour +1 
         If jour > nbjpm
          ind.b = 1 
          jour = 1 : mois = mois + 1 
          If mois > 12 : mois = 1:an = an +1: jour = 1:EndIf
         EndIf
         tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0)) 
         affcal(tdate$,ind.b)  
        Case 4
         tdate$ = FormatDate("%dd%mm%yyyy",Date()) 
         affcal(tdate$,1)
       EndSelect
   EndSelect
Until Event = #PB_Event_CloseWindow
End

Bonne soirée a tous
Michel

bonsoir MLD

Pas mal ton idée, merci pour le partage

Cordialement

Fort sympathique résultat.

Chez moi ça fait cela :

Uploaded with ImageShack.us

Alors, j'ai ajouté un peu de code :

Code : Tout sélectionner

;====== MLD ===
;=== 8/2/2012 =
;=== PB 4.61 ==
;==============

Enumeration 1 ; cal jour
#fenagd = 1
#btJm1 = 2
#btJp1 = 3
#btajd = 4
#text1 = 5
#text2 = 6
#text3 = 7
#text4 = 8

#txtj1 = 10
#txtj2 = 11
#txtj3 = 12
#txtj4 = 13
#txtj5 = 14
#txtj6 = 15
#txtj7 = 16
#txtj8 = 17
#txtj9 = 18
#txtj10 = 19
#txtj11 = 20
#txtj12 = 21
#txtj13 = 22
#txtj14 = 23
#txtj15 = 24
#txtj16 = 25
#txtj17 = 26
#txtj18 = 27
#txtj19 = 28
#txtj20 = 29
#txtj21 = 30
#txtj22 = 31
#txtj23 = 32
#txtj24 = 33
#txtj25 = 34
#txtj26 = 35
#txtj27 = 36
#txtj28 = 37
#txtj29 = 38
#txtj30 = 39
#txtj31 = 40
#txtj32 = 41
#txtj33 = 42
#txtj34 = 43
#txtj35 = 44
#txtj36 = 45
#txtj37 = 46
#txtj38 = 47
#txtj39 = 48
#txtj40 = 49
#txtj41 = 50
#txtj42 = 51

#txtj43 = 60
#txtj44 = 61
#txtj45 = 62
#txtj46 = 63
#txtj47 = 64
#txtj48 = 65
#txtj49 = 66
#txtj50 = 67
#txtj51 = 68
#txtj52 = 69
#txtj53 = 70
#txtj54 = 71
#txtj55 = 72
#txtj56 = 73
#txtj57 = 74
#txtj58 = 75
#txtj59 = 76
#txtj60 = 77
#txtj61 = 78
#txtj62 = 79
#txtj63 = 80
#txtj64 = 81
#txtj65 = 82
#txtj66 = 83
#txtj67 = 84
#txtj68 = 85
#txtj69 = 86
#txtj70 = 87
#txtj71 = 88
#txtj72 = 89
#txtj73 = 90
#txtj74 = 91
#txtj75 = 92
#txtj76 = 93
#txtj77 = 94
#txtj78 = 88
#txtj79 = 89
#txtj80 = 90
#txtj81 = 91
#txtj82 = 92
#txtj83 = 93
#txtj84 = 94
#txtj85 = 95
#txtj86 = 96
#txtj87 = 97
#txtj88 = 98
#txtj89 = 99
#txtj90 = 100
#txtj91 = 101

#txtm = 102
EndEnumeration
Enumeration 2 ;jours de la semaine + mois
#txtjs1 = 111
#txtjs2 = 112
#txtjs3 = 113
#txtjs4 = 114
#txtjs5 = 115
#txtjs6 = 116
#txtjs7 = 117
#txtjs8 = 118

#txt2js1 = 120
#txt2js2 = 121
#txt2js3 = 122
#txt2js4 = 123
#txt2js5 = 124
#txt2js6 = 125
#txt2js7 = 126
#txt2m = 128
EndEnumeration
Global FontID1 = LoadFont(1,"MS san serif",18 ,#PB_Font_HighQuality)
Global FontID2 = LoadFont(2,"MS san serif",32 ,#PB_Font_HighQuality)
Global tdate$
Declare affcal(tdate$,ind.b)
Procedure.l GetTextDimensions(hWndHDC, text$, *sz.SIZE, blnIsHDC = 1)
  Protected result, hdc, tm.TEXTMETRIC, abc.ABC, overhang, oldFont, char
  If text$ And *sz
    If blnIsHDC = 0 ; si 0 => hWndHDC= gadgetid()
      hdc = GetDC_(hWndHDC) ; alors on obtient le hdc
      If hdc = 0
        ProcedureReturn #False
      EndIf
      oldFont = SelectObject_(hdc, SendMessage_(hWndHDC, #WM_GETFONT, 0, 0))
    Else
      hdc = hWndHDC   ; sinon on a déjà le hdc
    EndIf
    ; dimensions. Equivalent à TextWidth() et TextHeight().
    GetTextExtentPoint32_(hdc, @text$, Len(text$), *sz)
    ;  @text$=GetGadgetText(numb), Len(text$)=Len(GetGadgetText(numb))
    
    ;Ajustement qui depend du type de font; raster ou true/open type.
    GetTextMetrics_(hdc, tm)
    ;*sz\cy=tm\tmHeight-tm\tmInternalLeading ;on peut enlever le internal leading height
    ;Debug *sz\cy
    ;Debug tm\tmHeight
    ;Debug tm\tmInternalLeading
    ;Debug tm\tmOverhang
    ;Debug tm\tmExternalLeading
    
    If tm\tmOverhang ;Raster font.
        *sz\cx + tm\tmOverhang
      Else
        char = Asc(Right(text$,1))
        GetCharABCWidths_(hdc, char, char, abc) 
        overhang = abc\abcC
        If overHang < 0
          *sz\cx - overHang
        EndIf
      EndIf
    ;Tidy up.
      If blnIsHDC = 0
        SelectObject_(hdc, oldFont)
        ReleaseDC_(hWndHDC, hdc)
      EndIf
  EndIf
  ProcedureReturn #True
EndProcedure
Procedure bissextile(annee)
    If (annee % 4 = 0 And annee % 100 <> 0) Or annee % 400 = 0
        bissextile= #True
    Else
        bissextile = #False
    EndIf
    ProcedureReturn bissextile
EndProcedure

Procedure Ffix(j,m)
Dt$ = Str(j) + "/" + Str(m)
Select Dt$
Case "1/1" ;1er janvier
  indf.B = 1
Case "1/5" ;1er mai
  indf.B = 1
Case "8/5" ;8 mai
  indf.B = 1
Case "14/7" ;14 juillet
  indf.B = 1
Case "15/8" ;15 aout
  indf.B = 1
Case "1/11" ;1 Novembre
  indf.B = 1
Case "11/11" ;11 novembre
  indf.B = 1
Case "25/12" ;25 décembre
  indf.B = 1
Default
  indf.B = 0
EndSelect
ProcedureReturn indf.B         
EndProcedure

Procedure.s calculnumjour(an,mois,jour,z1,z2,z3);calcul le nombre de jour écoulé a la date indiqué et ce qui reste
;======= calcul jour ==========
If bissextile(an) = 1
  totalj.w = 366
Else
  totalj.w = 365
EndIf
nbjt.w = DayOfYear(Date(an, mois, jour, 0, 0, 0))
diffjour.w = totalj - nbjt.w 
;======= calcul num semaine =====
Weeknum=0
For i=1 To DayOfYear(Date(an, mois, jour, 0, 0, 0))
day_of_week=DayOfWeek(AddDate( Date(Year(Date()),01,01,1,1,1), #PB_Date_Day , i-1))
If day_of_week= 1 And i <> 1
   Weeknum=Weeknum+1
EndIf
Next i
ProcedureReturn "Semaine: " + Str(Weeknum) + "     " + "Jour: " + Str(nbjt.w) + "/" + Str(totalj) + "-" +  Str(diffjour)
EndProcedure

Procedure calculnbjm(an,mois,jour,z1,z2,z3)
Select mois 
Case 1,3,5,7,8,10,12 ; calcul le nombre de jours par mois
  nbjpm.w = 31
Case 2
  If bissextile(an) = 1 ; tien compte des années bissextiles
   nbjpm.w = 29
  Else
   nbjpm.w = 28
  EndIf 
Case 4,6,9,11
  nbjpm.w = 30
EndSelect
ProcedureReturn  nbjpm.w
EndProcedure

Procedure cal()
; ============ cal gauche================
posh = 20
poshl = 21
posv = 50
posvh = 16
posjs = 34
posD.w = 0
For x = 10 To 51
posD = posD +1
Select x
  Case 11 To 16 ,18 To 23 ,25 To 30,32 To 37, 39 To 44,46 To 51
   posh = posh + poshl
EndSelect
If x = 17 Or x = 24 Or x = 31 Or x = 38 Or x = 45
  posv = posv + posvh
  posh = 20
EndIf 
TextGadget(x,posh,posv,20,15,"",#PB_Text_Center)
SetGadgetColor(x, #PB_Gadget_BackColor,$CDB69F)
If posD.w = 7
  SetGadgetColor(x, #PB_Gadget_FrontColor,$0000FF)
  posD.w = 0
EndIf 
Next
posh = 20
For y= 1 To 7
numsem$ = StringField("Lu,Ma,Me,Je,Ve,Sa,Di",y,",")
TextGadget(y +110,posh,posjs,20,15,numsem$,#PB_Text_Center)
SetGadgetColor(y +110, #PB_Gadget_BackColor,$FFE1CA)
posh = posh + poshl             
Next
TextGadget(102,20,posjs-16,140,15,"",#PB_Text_Center)
; ================ cal droit =====================
posh = 340
poshl = 21
posv = 50
posvh = 16
posjs = 34
posD = 0
For x = 60 To 101
posD = posD +1
Select x
  Case 61 To 66 ,68 To 73 ,75 To 80,82 To 87, 89 To 94, 96 To 101;place les textgad
   posh = posh + poshl
EndSelect
If x = 67 Or x = 74 Or x = 81 Or x = 88 Or x = 95;1er textgad de la ligne
  posv = posv + posvh
  posh = 340
EndIf 
TextGadget(x,posh,posv,20,15,"",#PB_Text_Center)
SetGadgetColor(x, #PB_Gadget_BackColor,$CDB69F)
If posD.w = 7
  SetGadgetColor(x, #PB_Gadget_FrontColor,$0000FF); color les dimanches
  posD.w = 0
EndIf   
Next
posh = 340
For y= 1 To 7
numsem$ = StringField("Lu,Ma,Me,Je,Ve,Sa,Di",y,",");inscrit les jours
TextGadget(y +120,posh,posjs,20,15,numsem$,#PB_Text_Center)
SetGadgetColor(y +120, #PB_Gadget_BackColor,$FFE1CA)
posh = posh + poshl             
Next
TextGadget(128,340,posjs-16,140,15,"",#PB_Text_Center);mois
EndProcedure

Procedure affcal(tdate$,ind.b)
jour.w = Val(Left(tdate$,2));transforme la date en chiffres
mois.w = Val(Mid(tdate$,3,2))
an.w = Val(Right(tdate$,4))
Moisl$ = "JANVIER,FEVRIER,MARS,AVRIL,MAI,JUIN,JUILLET,AOUT,SEPTEMBRE,OCTOBRE,NOVEMBRE,DECEMBRE"
Jourl$ = "Dimanche,Lundi,Mardi,Mercredi,Jeudi,Vendredi,Samedi"
For x = 10 To 51
SetGadgetText(x,"");raz des textgad et couleurs
SetGadgetColor(x,#PB_Gadget_FrontColor,$0)
Next
For xa = 16 To 51 Step 7
SetGadgetColor(xa,#PB_Gadget_FrontColor,$0000FF)
Next
If ind.b = 1
For xx = 60 To 101
  SetGadgetText(xx,"")
  SetGadgetColor(xx,#PB_Gadget_FrontColor,$0)
Next
  For xb = 66 To 101 Step 7
  SetGadgetColor(xb,#PB_Gadget_FrontColor,$0000FF)
Next
EndIf   
;=========== affiche cal gauche ===========
premjour.w = DayOfWeek(Date(an,mois,1,0,0,0));Calcul le 1er jour du mois
If premjour.w = 0 :premjour.w  = 7 :EndIf ; pour le placement donne le num 7 au dimanche au lieu de 0
nbjpm.w = calculnbjm(an,mois,jour,0,0,0)
jm = 0
For j = 10 + (premjour.w -1)  To (10 + nbjpm.w + (premjour.w-1))-1; remplis les textgads en tenant compte du
jm = jm +1                ; premier jour du mois
SetGadgetText(j,Str(jm))
If Ffix(jm,mois) = 1
  SetGadgetColor(J,#PB_Gadget_FrontColor,$0000FF)
EndIf 
Next
numois.w = Month(Date(an,mois,jour,0,0,0))
SetGadgetText(102,StringField(Moisl$,numois.w,",")+ " " + Str(an))
;============================ 
text$=StringField(Jourl$,DayOfWeek(Date(an,mois,jour,0,0,0))+1,",")
hwnd=TextGadget(5,185,15,135,30,text$,#PB_Text_Center)
 SetGadgetFont(5, FontID(1))
 GetTextDimensions(hWnd, text$, sz.SIZE, 0)
 ResizeGadget(5,#PB_Ignore,#PB_Ignore,#PB_Ignore,sz\cy)
 marge=5
 dy=sz\cy+15+marge
 
 text$=Str(jour)
 hwnd=TextGadget(6,185,50,135,40,text$,#PB_Text_Center)
 SetGadgetFont(6, FontID(2))
 SetGadgetColor(6, #PB_Gadget_FrontColor,$0045FF) 
 GetTextDimensions(hWnd, text$, sz.SIZE, 0)
 ResizeGadget(6,#PB_Ignore,dy,#PB_Ignore,sz\cy)
 marge=5
 dy=dy+sz\cy+marge
 text$=StringField(Moisl$,numois.w,",")
 hwnd=TextGadget(7,180,100,145,25,text$,#PB_Text_Center)
 SetGadgetFont(7, FontID(1))
 GetTextDimensions(hWnd, text$, sz.SIZE, 0)
 ResizeGadget(7,#PB_Ignore,dy,#PB_Ignore,sz\cy)
 marge=5
 dy=dy+sz\cy+marge
;==================
Static empljour.w
Static colorbase 
If empljour.w <> 0
SetGadgetColor(empljour.w,#PB_Gadget_FrontColor,colorbase)
EndIf
empljour.w = (10 + premjour.w + jour) -2
colorbase = GetGadgetColor(empljour.w,#PB_Gadget_FrontColor)
SetGadgetColor(empljour,#PB_Gadget_FrontColor,$00FFFF)
;=================
TextGadget(8,170,dy,160,17,calculnumjour(an,mois,jour,0,0,0),#PB_Text_Center)
;==================
SetGadgetColor(8,#PB_Gadget_FrontColor,$858585)
calculnumjour(an,mois,jour,0,0,0)
;============ affiche cal droit ===============
;attention si cal gauche est a 12 mois rectifier la date
If ind = 1
If mois.w = 12
  jour.w = Val(Left(tdate$,2))
  mois.w = 0
  an.w = an.w + 1
EndIf
  premjour2.w = DayOfWeek(Date(an,mois+1,1,0,0,0))
If premjour2.w = 0 :premjour2.w = 7 :EndIf
mois = mois +1
nbjpm2.w = calculnbjm(an,mois,jour,0,0,0); **************************
jmd = 0
For jd = 60 + (premjour2.w-1) To (60 + nbjpm2.w + (premjour2.w-1))-1
  jmd = jmd +1
  SetGadgetText(jd,Str(jmd))
  If Ffix(jmd,mois) = 1
  SetGadgetColor(Jd,#PB_Gadget_FrontColor,$0000FF)
EndIf
Next
numois2.w = Month(Date(an,mois,1,0,0,0))
SetGadgetText(128,StringField(Moisl$,numois2.w,",")+ " " + Str(an))
EndIf
EndProcedure
OpenWindow(1, 0, 0, 500, 300, "Début d'héphéméride", #PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget)
cal()
tdate$ = FormatDate("%dd%mm%yyyy",Date())
affcal(tdate$,1)
ButtonGadget(2,200, 250,40,30,Chr(60))
ButtonGadget(4,240, 250,40,30,Chr(60)+ Chr(62))
ButtonGadget(3,280, 250,40,30,Chr(62))
Repeat
   Event = WaitWindowEvent()

   Select Event
      Case #PB_Event_Menu
      Select EventMenu() ; Menus

      EndSelect

      Case #PB_Event_Gadget
       Select EventGadget() ; Gadgets
        Case 2
        ind.b = 0
         jour.w = Val(Left(tdate$,2));transforme la date en chiffres
         mois.w = Val(Mid(tdate$,3,2))
         an.w = Val(Right(tdate$,4))
         jour = jour -1
         If jour = 0
           ind.b = 1
           mois = mois - 1 : jour = calculnbjm(an,mois,1,0,0,0)
          If mois = 0
           mois = 12
           an = an -1
           jour = calculnbjm(an,mois,1,0,0,0)
          EndIf
         EndIf
         tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0))
         affcal(tdate$,ind.b)     
        Case 3
        ind = 0
         jour.w = Val(Left(tdate$,2));transforme la date en chiffres
         mois.w = Val(Mid(tdate$,3,2))
         an.w = Val(Right(tdate$,4))
         nbjpm.w = calculnbjm(an,mois,jour,0,0,0)
         jour = jour +1
         If jour > nbjpm
          ind.b = 1
          jour = 1 : mois = mois + 1
          If mois > 12 : mois = 1:an = an +1: jour = 1:EndIf
         EndIf
         tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0))
         affcal(tdate$,ind.b) 
        Case 4
         tdate$ = FormatDate("%dd%mm%yyyy",Date())
         affcal(tdate$,1)
       EndSelect
   EndSelect
Until Event = #PB_Event_CloseWindow
End

Bonjour Mesa

Bizarre

L'écran que tu montres c'est quelle version de Window

Car j'ai programmé en XP.
Mais j'ai essayé sur mon portable en Window7 et petit écran. Auncun problème.
Tu as un ordinateur préhistorique

De toute manière le code est libre tu fais se que tu veux

Ton code trés bien.

a + Michel

C'est vrai que c'est un vieux XP mais.. au petits oignons.
J'ai enlevé les thèmes et tout ce qui est inutile, réglages dans la bases de registre qui vont bien...
J'ai fait ça pour l'affichage :
Panneau de configuration\Affichage\Paramètres\Avancé\Général
Affichage
Paramètre PPP = Grand taille(120ppp) 125% taille normale

Du coup, windows fait un zoom de 125% et certains textes ne rentre plus dans les boutons, etc.

Et tant que mon vieux XP mitonné est tout aussi réactif et bien souvent plus rapide qu'un 7 64b avec 2 cores, je le garde.
Par contre, pas question d'installer un jeu récent.

Mesa.

Une autre façon de faire, plus simple.
Ajout d'un code en ligne 130

Code : Tout sélectionner

;====== MLD ===
;=== 8/2/2012 =
;=== PB 4.61 ==
;==============

Enumeration 1 ; cal jour
#fenagd = 1
#btJm1 = 2
#btJp1 = 3
#btajd = 4
#text1 = 5
#text2 = 6
#text3 = 7
#text4 = 8

#txtj1 = 10
#txtj2 = 11
#txtj3 = 12
#txtj4 = 13
#txtj5 = 14
#txtj6 = 15
#txtj7 = 16
#txtj8 = 17
#txtj9 = 18
#txtj10 = 19
#txtj11 = 20
#txtj12 = 21
#txtj13 = 22
#txtj14 = 23
#txtj15 = 24
#txtj16 = 25
#txtj17 = 26
#txtj18 = 27
#txtj19 = 28
#txtj20 = 29
#txtj21 = 30
#txtj22 = 31
#txtj23 = 32
#txtj24 = 33
#txtj25 = 34
#txtj26 = 35
#txtj27 = 36
#txtj28 = 37
#txtj29 = 38
#txtj30 = 39
#txtj31 = 40
#txtj32 = 41
#txtj33 = 42
#txtj34 = 43
#txtj35 = 44
#txtj36 = 45
#txtj37 = 46
#txtj38 = 47
#txtj39 = 48
#txtj40 = 49
#txtj41 = 50
#txtj42 = 51

#txtj43 = 60
#txtj44 = 61
#txtj45 = 62
#txtj46 = 63
#txtj47 = 64
#txtj48 = 65
#txtj49 = 66
#txtj50 = 67
#txtj51 = 68
#txtj52 = 69
#txtj53 = 70
#txtj54 = 71
#txtj55 = 72
#txtj56 = 73
#txtj57 = 74
#txtj58 = 75
#txtj59 = 76
#txtj60 = 77
#txtj61 = 78
#txtj62 = 79
#txtj63 = 80
#txtj64 = 81
#txtj65 = 82
#txtj66 = 83
#txtj67 = 84
#txtj68 = 85
#txtj69 = 86
#txtj70 = 87
#txtj71 = 88
#txtj72 = 89
#txtj73 = 90
#txtj74 = 91
#txtj75 = 92
#txtj76 = 93
#txtj77 = 94
#txtj78 = 88
#txtj79 = 89
#txtj80 = 90
#txtj81 = 91
#txtj82 = 92
#txtj83 = 93
#txtj84 = 94
#txtj85 = 95
#txtj86 = 96
#txtj87 = 97
#txtj88 = 98
#txtj89 = 99
#txtj90 = 100
#txtj91 = 101

#txtm = 102
EndEnumeration
Enumeration 2 ;jours de la semaine + mois
#txtjs1 = 111
#txtjs2 = 112
#txtjs3 = 113
#txtjs4 = 114
#txtjs5 = 115
#txtjs6 = 116
#txtjs7 = 117
#txtjs8 = 118

#txt2js1 = 120
#txt2js2 = 121
#txt2js3 = 122
#txt2js4 = 123
#txt2js5 = 124
#txt2js6 = 125
#txt2js7 = 126
#txt2m = 128
EndEnumeration
; Global FontID1 = LoadFont(1,"MS san serif",18 ,#PB_Font_HighQuality)
; Global FontID2 = LoadFont(2,"MS san serif",32 ,#PB_Font_HighQuality)
Define lhDC.l = GetDC_(#Null)
Define lPpp.l = GetDeviceCaps_(lhDC, 88)
Define lres.l = ReleaseDC_(#Null, lhDC)
police1=18
police2=32
police1=Int(police1*96/lPpp)
police2=(police2*96/lPpp)
; Debug police1
; Debug police2
Global FontID1 = LoadFont(1,"MS san serif",police1 ,#PB_Font_HighQuality)
Global FontID2 = LoadFont(2,"MS san serif",police2 ,#PB_Font_HighQuality)
Global tdate$
Declare affcal(tdate$,ind.b)

Procedure bissextile(annee)
    If (annee % 4 = 0 And annee % 100 <> 0) Or annee % 400 = 0
        bissextile= #True
    Else
        bissextile = #False
    EndIf
    ProcedureReturn bissextile
EndProcedure

Procedure Ffix(j,m)
Dt$ = Str(j) + "/" + Str(m)
Select Dt$
Case "1/1" ;1er janvier
  indf.B = 1
Case "1/5" ;1er mai
  indf.B = 1
Case "8/5" ;8 mai
  indf.B = 1
Case "14/7" ;14 juillet
  indf.B = 1
Case "15/8" ;15 aout
  indf.B = 1
Case "1/11" ;1 Novembre
  indf.B = 1
Case "11/11" ;11 novembre
  indf.B = 1
Case "25/12" ;25 décembre
  indf.B = 1
Default
  indf.B = 0
EndSelect
ProcedureReturn indf.B         
EndProcedure

Procedure.s calculnumjour(an,mois,jour,z1,z2,z3);calcul le nombre de jour écoulé a la date indiqué et ce qui reste
;======= calcul jour ==========
If bissextile(an) = 1
  totalj.w = 366
Else
  totalj.w = 365
EndIf
nbjt.w = DayOfYear(Date(an, mois, jour, 0, 0, 0))
diffjour.w = totalj - nbjt.w 
;======= calcul num semaine =====
Weeknum=0
For i=1 To DayOfYear(Date(an, mois, jour, 0, 0, 0))
day_of_week=DayOfWeek(AddDate( Date(Year(Date()),01,01,1,1,1), #PB_Date_Day , i-1))
If day_of_week= 1 And i <> 1
   Weeknum=Weeknum+1
EndIf
Next i
ProcedureReturn "Semaine: " + Str(Weeknum) + "     " + "Jour: " + Str(nbjt.w) + "/" + Str(totalj) + "-" +  Str(diffjour)
EndProcedure

Procedure calculnbjm(an,mois,jour,z1,z2,z3)
Select mois 
Case 1,3,5,7,8,10,12 ; calcul le nombre de jours par mois
  nbjpm.w = 31
Case 2
  If bissextile(an) = 1 ; tien compte des années bissextiles
   nbjpm.w = 29
  Else
   nbjpm.w = 28
  EndIf 
Case 4,6,9,11
  nbjpm.w = 30
EndSelect
ProcedureReturn  nbjpm.w
EndProcedure

Procedure cal()
; ============ cal gauche================
posh = 20
poshl = 21
posv = 50
posvh = 16
posjs = 34
posD.w = 0
For x = 10 To 51
posD = posD +1
Select x
  Case 11 To 16 ,18 To 23 ,25 To 30,32 To 37, 39 To 44,46 To 51
   posh = posh + poshl
EndSelect
If x = 17 Or x = 24 Or x = 31 Or x = 38 Or x = 45
  posv = posv + posvh
  posh = 20
EndIf 
TextGadget(x,posh,posv,20,15,"",#PB_Text_Center)
SetGadgetColor(x, #PB_Gadget_BackColor,$CDB69F)
If posD.w = 7
  SetGadgetColor(x, #PB_Gadget_FrontColor,$0000FF)
  posD.w = 0
EndIf 
Next
posh = 20
For y= 1 To 7
numsem$ = StringField("Lu,Ma,Me,Je,Ve,Sa,Di",y,",")
TextGadget(y +110,posh,posjs,20,15,numsem$,#PB_Text_Center)
SetGadgetColor(y +110, #PB_Gadget_BackColor,$FFE1CA)
posh = posh + poshl             
Next
TextGadget(102,20,posjs-16,140,15,"",#PB_Text_Center)
; ================ cal droit =====================
posh = 340
poshl = 21
posv = 50
posvh = 16
posjs = 34
posD = 0
For x = 60 To 101
posD = posD +1
Select x
  Case 61 To 66 ,68 To 73 ,75 To 80,82 To 87, 89 To 94, 96 To 101;place les textgad
   posh = posh + poshl
EndSelect
If x = 67 Or x = 74 Or x = 81 Or x = 88 Or x = 95;1er textgad de la ligne
  posv = posv + posvh
  posh = 340
EndIf 
TextGadget(x,posh,posv,20,15,"",#PB_Text_Center)
SetGadgetColor(x, #PB_Gadget_BackColor,$CDB69F)
If posD.w = 7
  SetGadgetColor(x, #PB_Gadget_FrontColor,$0000FF); color les dimanches
  posD.w = 0
EndIf   
Next
posh = 340
For y= 1 To 7
numsem$ = StringField("Lu,Ma,Me,Je,Ve,Sa,Di",y,",");inscrit les jours
TextGadget(y +120,posh,posjs,20,15,numsem$,#PB_Text_Center)
SetGadgetColor(y +120, #PB_Gadget_BackColor,$FFE1CA)
posh = posh + poshl             
Next
TextGadget(128,340,posjs-16,140,15,"",#PB_Text_Center);mois
EndProcedure

Procedure affcal(tdate$,ind.b)
jour.w = Val(Left(tdate$,2));transforme la date en chiffres
mois.w = Val(Mid(tdate$,3,2))
an.w = Val(Right(tdate$,4))
Moisl$ = "JANVIER,FEVRIER,MARS,AVRIL,MAI,JUIN,JUILLET,AOUT,SEPTEMBRE,OCTOBRE,NOVEMBRE,DECEMBRE"
Jourl$ = "Dimanche,Lundi,Mardi,Mercredi,Jeudi,Vendredi,Samedi"
For x = 10 To 51
SetGadgetText(x,"");raz des textgad et couleurs
SetGadgetColor(x,#PB_Gadget_FrontColor,$0)
Next
For xa = 16 To 51 Step 7
SetGadgetColor(xa,#PB_Gadget_FrontColor,$0000FF)
Next
If ind.b = 1
For xx = 60 To 101
  SetGadgetText(xx,"")
  SetGadgetColor(xx,#PB_Gadget_FrontColor,$0)
Next
  For xb = 66 To 101 Step 7
  SetGadgetColor(xb,#PB_Gadget_FrontColor,$0000FF)
Next
EndIf   
;=========== affiche cal gauche ===========
premjour.w = DayOfWeek(Date(an,mois,1,0,0,0));Calcul le 1er jour du mois
If premjour.w = 0 :premjour.w  = 7 :EndIf ; pour le placement donne le num 7 au dimanche au lieu de 0
nbjpm.w = calculnbjm(an,mois,jour,0,0,0)
jm = 0
For j = 10 + (premjour.w -1)  To (10 + nbjpm.w + (premjour.w-1))-1; remplis les textgads en tenant compte du
jm = jm +1                ; premier jour du mois
SetGadgetText(j,Str(jm))
If Ffix(jm,mois) = 1
  SetGadgetColor(J,#PB_Gadget_FrontColor,$0000FF)
EndIf 
Next
numois.w = Month(Date(an,mois,jour,0,0,0))
SetGadgetText(102,StringField(Moisl$,numois.w,",")+ " " + Str(an))


TextGadget(5,185,15,135,30,StringField(Jourl$,DayOfWeek(Date(an,mois,jour,0,0,0))+1,","),#PB_Text_Center)
SetGadgetFont(5, FontID(1))
TextGadget(6,185,50,135,40,Str(jour),#PB_Text_Center)
SetGadgetFont(6, FontID(2))
SetGadgetColor(6, #PB_Gadget_FrontColor,$0045FF) 
TextGadget(7,180,100,145,25,StringField(Moisl$,numois.w,","),#PB_Text_Center)
SetGadgetFont(7, FontID(1))
Static empljour.w
Static colorbase 
If empljour.w <> 0
SetGadgetColor(empljour.w,#PB_Gadget_FrontColor,colorbase)
EndIf
empljour.w = (10 + premjour.w + jour) -2
colorbase = GetGadgetColor(empljour.w,#PB_Gadget_FrontColor)
SetGadgetColor(empljour,#PB_Gadget_FrontColor,$00FFFF)
TextGadget(8,170,130,160,17,calculnumjour(an,mois,jour,0,0,0),#PB_Text_Center)
SetGadgetColor(8,#PB_Gadget_FrontColor,$858585)
calculnumjour(an,mois,jour,0,0,0)
;============ affiche cal droit ===============
;attention si cal gauche est a 12 mois rectifier la date
If ind = 1
If mois.w = 12
  jour.w = Val(Left(tdate$,2))
  mois.w = 0
  an.w = an.w + 1
EndIf
  premjour2.w = DayOfWeek(Date(an,mois+1,1,0,0,0))
If premjour2.w = 0 :premjour2.w = 7 :EndIf
mois = mois +1
nbjpm2.w = calculnbjm(an,mois,jour,0,0,0); **************************
jmd = 0
For jd = 60 + (premjour2.w-1) To (60 + nbjpm2.w + (premjour2.w-1))-1
  jmd = jmd +1
  SetGadgetText(jd,Str(jmd))
  If Ffix(jmd,mois) = 1
  SetGadgetColor(Jd,#PB_Gadget_FrontColor,$0000FF)
EndIf
Next
numois2.w = Month(Date(an,mois,1,0,0,0))
SetGadgetText(128,StringField(Moisl$,numois2.w,",")+ " " + Str(an))
EndIf
EndProcedure
OpenWindow(1, 0, 0, 500, 300, "Début d'héphéméride", #PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget)
cal()
tdate$ = FormatDate("%dd%mm%yyyy",Date())
affcal(tdate$,1)
ButtonGadget(2,200, 250,40,30,Chr(60))
ButtonGadget(4,240, 250,40,30,Chr(60)+ Chr(62))
ButtonGadget(3,280, 250,40,30,Chr(62))
Repeat
   Event = WaitWindowEvent()

   Select Event
      Case #PB_Event_Menu
      Select EventMenu() ; Menus

      EndSelect

      Case #PB_Event_Gadget
       Select EventGadget() ; Gadgets
        Case 2
        ind.b = 0
         jour.w = Val(Left(tdate$,2));transforme la date en chiffres
         mois.w = Val(Mid(tdate$,3,2))
         an.w = Val(Right(tdate$,4))
         jour = jour -1
         If jour = 0
           ind.b = 1
           mois = mois - 1 : jour = calculnbjm(an,mois,1,0,0,0)
          If mois = 0
           mois = 12
           an = an -1
           jour = calculnbjm(an,mois,1,0,0,0)
          EndIf
         EndIf
         tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0))
         affcal(tdate$,ind.b)     
        Case 3
        ind = 0
         jour.w = Val(Left(tdate$,2));transforme la date en chiffres
         mois.w = Val(Mid(tdate$,3,2))
         an.w = Val(Right(tdate$,4))
         nbjpm.w = calculnbjm(an,mois,jour,0,0,0)
         jour = jour +1
         If jour > nbjpm
          ind.b = 1
          jour = 1 : mois = mois + 1
          If mois > 12 : mois = 1:an = an +1: jour = 1:EndIf
         EndIf
         tdate$ = FormatDate("%dd%mm%yyyy",Date(an,mois,jour,0,0,0))
         affcal(tdate$,ind.b) 
        Case 4
         tdate$ = FormatDate("%dd%mm%yyyy",Date())
         affcal(tdate$,1)
       EndSelect
   EndSelect
Until Event = #PB_Event_CloseWindow
End

Tenez un petit algorithme pour calculer Paques

Code : Tout sélectionner

Procedure CalculPaques(Annee)
  
	Protected var1, var2, var3, var4, var5, var6, var7         
	var1 = (Annee % 19) + 1
	var2 = Int(Annee / 100) + 1
	var3 = Int((3 * var2) / 4) - 12
	var4 = Int(((8 * var2) + 5) / 25) - 5
	var5 = Int((5 * Annee) / 4) - var3 - 10
	var6 = (11 * var1 + 20 + var4 - var3) % 30
	
	If (var6 = 25 And var1 > 11) Or (var6 = 24)
		var6 = var6 + 1
	EndIf
	
	var7 = 44 - var6
	
	If var7 < 21
		var7 = var7 + 30
	EndIf
	
	var7 = var7 + 7
	var7 = var7 - (var5 + var7) % 7
	
	
	If var7 <= 31
		Paques$ = Str(var7) + "/3/" + Str(Annee)
	Else
		Paques$ = Str(var7 - 31) + "/4/" + Str(Annee)
	EndIf
  
EndProcedure

Ensuite c'est simple:
le vendredi saint tombe deux jours avant pâques,
l'ascension 39 jours après,
pentecôte 49 jours après ...

Bonjour Berfau

Oui mais attention il existe de nombreux algorithmes pour le calcul de la date de Paques.certains ne sont pas fiables a 100% dans le temps. Perso j'utilise celui ci, réalisé par je ne sais plus quelle université.

Code : Tout sélectionner

Procedure.s calulftrelig(jr,mr,y)
datref$ = FormatDate("%dd%mm%yyyy",Date(y,mr,jr,0,0,0)) 
;dimanche de paque
c.w = y / 100 
n.w =  (y % 19) 
k.w = (c - 17) / 25 
b.w = c /4 
e.w = (c - k) / 3 
f.w = c - b - e + (19 * n) + 15 
h.w =  (f % 30) 
p.w = h / 28 
q.w = 29 / (h + 1)
r.w = (21 - n) / 11 
i.w = h - (p * (1 - (p * q * r)))
s.w = y / 4 
t.w = c / 4 
u.w = y + s + i + 2 - c + t 
j.w =  (u % 7) 
w.w = (i - j + 40) / 44  
m.w = 3 + w  
x.w = m / 4 
d.w = i - j + 28 - (31 * x)
 Dimanchepaque$ = FormatDate("%dd%mm%yyyy",Date(y,m,d,0,0,0))  
 lundipaque$ = FormatDate("%dd%mm%yyyy",AddDate(Date(y,m,d,0,0,0),#PB_Date_Day,1))
 jeudiasc$ = FormatDate("%dd%mm%yyyy",AddDate(Date(y,m,d,0,0,0),#PB_Date_Day,39))
 dimanchepent$ =  FormatDate("%dd%mm%yyyy",AddDate(Date(y,m,d,0,0,0),#PB_Date_Day,49))
 lundipent$ = FormatDate("%dd%mm%yyyy",AddDate(Date(y,m,d,0,0,0),#PB_Date_Day,50)) 
 indftm$ = ""
 If datref$ = Dimanchepaque$
  indftm$ = "Dimanche de paques"
 EndIf 
 If datref$ = lundipaque$
  indftm$ = "Lundi de paques"
 EndIf 
 If datref$ = jeudiasc$
  indftm$ = "Jeudi de l'ascension"
 EndIf
 If datref$ = dimanchepent$
  indftm$ = "Pentecote"
 EndIf  
 If datref$ = lundipent$
  indftm$ = "Lundi de pentecote"
 EndIf
ProcedureReturn indftm$
EndProcedure

Debug  calulftrelig(31,03,2013)

a +
Michel

Il manquait un petit ProcedureReturn...

Code : Tout sélectionner

Procedure.s CalculPaques(Annee)
 
   Protected var1, var2, var3, var4, var5, var6, var7         
   var1 = (Annee % 19) + 1
   var2 = Int(Annee / 100) + 1
   var3 = Int((3 * var2) / 4) - 12
   var4 = Int(((8 * var2) + 5) / 25) - 5
   var5 = Int((5 * Annee) / 4) - var3 - 10
   var6 = (11 * var1 + 20 + var4 - var3) % 30
   
   If (var6 = 25 And var1 > 11) Or (var6 = 24)
      var6 = var6 + 1
   EndIf
   
   var7 = 44 - var6
   
   If var7 < 21
      var7 = var7 + 30
   EndIf
   
   var7 = var7 + 7
   var7 = var7 - (var5 + var7) % 7
   
   
   If var7 <= 31
     Paques$ = "Dimanche " + Str(var7) + "/3/" + Str(Annee)
     Else
      Paques$ = "Dimanche " + Str(var7 - 31) + "/4/" + Str(Annee)
   EndIf
 ProcedureReturn Paques$
EndProcedure

 Debug CalculPaques(2012)
 
; le vendredi saint tombe deux jours avant pâques,
; l'ascension 39 jours après,
; pentecôte 49 jours après ...

Mesa.

Salut Mesa
Nos post ce sont croisés

En effet j'ai oublié le ProcedureReturn Paques$
Un oublie dû au fait que c'est extrait d'un programme VB6 que j'avais fait il y a longtemps et je n'ai pas été au bout de la conversion.

L’algorithme que je présente est bon au moins jusqu'en 2022. Possible qu'il ne marche pas en 2122, je n'es pas fait la vérification. Il m'indique 29/03/2122.

PureBasic

Début d'héphéméride ou Agenda

Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda

Re: Début d'héphéméride ou Agenda