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

MLD · **Inscription:** Jeu 05/Fév/2009 17:58 **Messages:** 484

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 :lol:

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

Vous pouvez en faire ce que vous voulez :lol:

Code:

;====== 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

kernadec · **Inscription:** Ven 25/Avr/2008 11:14 **Messages:** 945

bonsoir MLD

Pas mal ton idée, merci pour le partage

Cordialement

Ar-S · **Inscription:** Dim 09/Oct/2005 16:51 **Messages:** 5222

Fort sympathique résultat.

Mesa · **Inscription:** Mer 14/Sep/2011 16:59 **Messages:** 335

Chez moi ça fait cela :

Uploaded with ImageShack.us

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

Code:

;====== 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

MLD · **Inscription:** Jeu 05/Fév/2009 17:58 **Messages:** 484

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 :mrgreen:

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

Ton code trés bien. :lol:

a + Michel

Mesa · **Inscription:** Mer 14/Sep/2011 16:59 **Messages:** 335

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.

Mesa · **Inscription:** Mer 14/Sep/2011 16:59 **Messages:** 335

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

Code:

;====== 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

Berfau · **Inscription:** Ven 27/Aoû/2010 9:56 **Messages:** 3

Tenez un petit algorithme pour calculer Paques

Code:

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 ...

MLD · **Inscription:** Jeu 05/Fév/2009 17:58 **Messages:** 484

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é. :lol:

Code:

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

Mesa · **Inscription:** Mer 14/Sep/2011 16:59 **Messages:** 335

Il manquait un petit ProcedureReturn...

Code:

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.

MLD · **Inscription:** Jeu 05/Fév/2009 17:58 **Messages:** 484

Salut Mesa
Nos post ce sont croisés

Berfau · **Inscription:** Ven 27/Aoû/2010 9:56 **Messages:** 3

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. :oops:

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

Qui est en ligne