rem ' ***** Fabricateur de calendriers perpétuels ***** Fabric-Calendrier-perpet
dim ex , ie, j1 , j2 , j3 , m1 , m2 , m3 , tt , c$ , e$ , o$ , t$
dim a , b , c , d , e , f , g , h , i , j , k , m , n , p , q , r
dim s , t , u , v , x , y , w , z , j$(7) , m$(12)
data "Dim." , "Lun." , "Mar." , "Mer." , "Jeu.." , "Ven." , "Sam"
data "JAN" , "FEV" , "MAR" , "AVR" , "MAI" , "JUIN" , "JUIL"
data "AOU" , "SEP" , "OCT" , "NOV" , "DEC"
label calcul , fin , ecran , choix , excel , aide , egal , fini
c$="Auteur de ce programme : jjn4"
for i=0 to 6
read j$(i)
next i
for i=1 to 12
read m$(i)
next i
width 0,400 : height 0,240 : caption 0,"Fabricateur de calendriers"
alpha 1
left 1,60 : top 1,40
font_bold 1
font_size 1,14
caption 1,"CALENDRIER PERPÉTUEL"
alpha 2
left 2,100 : top 2,85
caption 2,"Quelle année"
edit 3
left 3,180 : top 3,80 : width 3,60 : height 3,21
on_change 3,egal
set_focus 3
button 4
left 4,250 : top 4,125 : width 4,60 : height 4,21
caption 4,"Calculer"
on_click 4,ecran
alpha 5
left 5,10 : top 5,170
caption 5,c$
spin 7
left 7,160 : top 7,2 : width 7,53
on_change 7,choix
hide 7
button 9
left 9,287 : top 9,2 : width 9,60 : height 9,21
caption 9,"Imprimer"
on_click 9,excel
hide 9
button 10
left 10,253 : top 10,2 : width 10,40 : height 10,21
caption 10,"Aide"
on_click 10,aide
hide 10
form 11
left 11,200 : top 11,100 : width 11,430 : height 11,405
caption 11,"Aide au fabricateur de calendrier perpétuel"
hide 11
alpha 12
parent 12,11
left 12,10 : top 12,8
caption 12,a$
end
egal:
if text$(3)<>"" then position 7,text$(3)
return
ecran:
caption 5,"ATTENDEZ" : wait 1
if ie=0
width 0,1019 : height 0,637
left 2,20 : top 2,4
left 3,95 : top 3,2
tt=0 : if text$(3)<>"" then tt=val(text$(3))
show 7 : position 7,tt
left 1,500 : top 1,1
caption 1,"CALENDRIER "+text$(3)
left 5,850 : top 5,4
left 4,220 : top 4,2
picture 8 : left 8,0 : top 8,25 : width 8,1011 : height 8,578
color 8,192,192,192 : show 9 : left 10,353 : show 10
for i=9 to 20
for j=1 to 32
alpha (i-8)*32+j : alpha (i-8)*32+j+400
left (i-8)*32+j,(i-9)*84+2 : left (i-8)*32+j+400,(i-9)*84+2
top (i-8)*32+j,j*18+8 : top (i-8)*32+j+400,j*18+8
width (i-8)*32+j,83 : width (i-8)*32+j+400,83
color (i-8)*32+j,255,255,255 : color (i-8)*32+j+400,255,255,255
next j
color (i-8)*32+1,180,255,255
next i
else
for i=9 to 20
for j=1 to 32
caption (i-8)*32+j+400,""
color (i-8)*32+j,255,255,255
color (i-8)*32+j+400,255,255,255
next j
color (i-8)*32+1,180,255,255
next i
caption 1,"CALENDRIER "+text$(3)
end_if
ie=1
gosub calcul
return
choix:
text 3,position(7)
return
excel:
message "En passant à EXCEL, vous fermez le calendrier"
ex=1 : gosub calcul
return
aide:
execute "Fabric-Cal-Aide.exe"
return
calcul:
t$=text$(3) : if t$="" then return
if val(t$)<1583 or val(t$)>4581 then beep : caption 5,"Non, pas possible (1583 à 4581)" : return
tt=val(t$)
' Calcul du lundi de Pâques - Algorithme de Oudin
g=tt-int(tt/19)*19
w=int(tt/100)
d=int(w/4)
e=int((8*w+13)/25)
h=19*g+w-d-e+15-int((19*g+w-d-e+15)/30)*30
k=int(h/28)
u=int(29/(h+1))
q=int((21-g)/11)
v=(k*u*q-1)*k+h
z=int(tt/4)+tt
n=z+v+2+d-w
f=n-int(n/7)*7
r=28+v-f
if h=29 and r=50 then r=57
if h=28 and g>10 and r=49 then r=56
if r>30
j1=r-30 : m1=4
else
j1=r+1 : m1=3
end_if
' Calcul du jeudi de l'Ascension
y=r+39
if y>92
j3=y-92 : m3=6
else
j3=y-61 : m3=5
end_if
' Calcul du lundi de Pentecôte
x=r+50
if x>92
j2=x-92 : m2=6
else
j2=x-61 : m2=5
end_if
' Calcul du jour de la semaine et affichage
c=val(left$(t$,2))
a=val(right$(t$,2))
if ex=1 then excel_start : excel_file_new 1
for m=1 to 12
for j=1 to 31
select m
case 1 : t=0
case 2 : t=3
case 3 : t=3
case 4 : t=6
case 5 : t=1
case 6 : t=4
case 7 : t=6
case 8 : t=2
case 9 : t=5
case 10 : t=0
case 11 : t=3
case 12 : t=5
end_select
if a=0 and m<3
p=(20-c)*2+int((c-1)/4)-5
else
p=(19-c)*2+int(c/4)-4
end_if
b=int(a/4)
if a/4=int(a/4) and m<3 then b=b-1
s=(j+t+a+b+p)-7*int((j+t+a+b+p)/7) : s=s-int(s/7)*7
if j=31 and (m=2 or m=4 or m=6 or m=9 or m=11) then goto fin
if (m=2 and j>29) or (m=2 and a/4<>int(a/4) and j>28) then goto fin
if a=0 and c/4<>int(c/4) and m=2 and j=29 then goto fin
e$="" : if s=0 then e$="***"
if j=1 and m=5 and tt>1946 then e$="***"
if j=8 and m=5 and tt>1952 and tt<1960 then e$="***"
if j=8 and m=5 and tt>1981 then e$="***"
if j=14 and m=7 and tt>1879 then e$="***"
if (j=15 and m=8) or (j=1 and m=11) then e$="***"
if j=11 and m=11 and tt>1921 then e$="***"
if (j=25 and m=12) or (j=1 and m=1) then e$="***"
if (j=j1 and m=m1) or (j=j2 and m=m2) or (j=j3 and m=m3) then e$="***"
o$="" : if j<10 then o$="0"
if ex=0 then caption m*32+j+401,j$(s)+"."+o$+str$(j)+e$
if e$="***" and ex=0
if j$(s)="Dim."
color m*32+j+1,255,255,0 : color m*32+j+401,255,255,0
else
color m*32+j+1,255,204,153 : color m*32+j+401,255,204,153
end_if
end_if
if ex=1 then excel_write chr$(64+m*2-1)+str$(j+2),j$(s)+"."+o$+str$(j)+e$
fin:
next j
if ex=0
caption m*32+401," "+m$(m)+".."+t$ : color m*32+401,180,255,255
font_size m*32+401,10 : font_bold m*32+401
end_if
if ex=1 then excel_write chr$(64+m*2-1)+"2",m$(m)+".."+t$
next m
for j=1 to 19 step 6
if ex=1 then excel_write chr$(64+j)+"1","CALENDRIER "+t$
next j
caption 5,c$
if ex=1 then goto fini
ex=0
return
fini:
terminate |
Accueil 
Calendrier
)
