calendario en free pascal
Esta pregunta es muy parecida a esta: http://www.lawebdelprogramador.com/foros/Pascal_Turbo_Pascal/1289562-sugerencias_para_hacer_calendario_en_pascal.html
Pero aquí te doy mi respusta otra vez, sólo te hago la observación que le hice a Juan: la visualición se altera por el proceso de copiado y pegado, sí te interesa el código correcto .PAS mándame un correo y te lo envío.
Program C6_P7;
Uses Crt;
Const d1=1 ;
Var d,m,a : Integer;
n,nd : LongInt;
Salir_SN : Char;
Procedure Instrucciones_C6_P7;
Begin
TextColor (White);
Write ('*****************************');
TextColor (Green);
Write (' Dedicado para M.E.Z. de A.Eduardo G.A. ');
TextColor (White);
WriteLn ('**');
WriteLn;
WriteLn ('Este programa solicita una fecha en el formato: 21/octubre/1980 para visualizar');
WriteLn ('un calendario donde se podr saber que d¡a de la semana fue; el intervalo per- ');
WriteLn ('mitido para el a¤o es de [1,32767]. Pese a que todos los meses se consideran de');
WriteLn ('31 dias no existe error en las fechas reales.');
WriteLn;
WriteLn ('*************************************************************** 7/Enero/2007 **')
{programa en construcci¢n, pues existe un desplazamiento de 2 dias en las fechas}
End;
Procedure LeerDia (Var dn : Integer);
Var Error,b1 : Integer;
Begin
TextColor (Green);
Write ('D¡a: ');
Repeat
GoToXY (6,10);
TextColor (White);
Write (' ': 80);
GoToXY (6,10);
ReadLn (dn);
Error := IOResult;
Case dn Of
1..31 : b1:=0
Else b1:=1
End;
If (Error<>0) Or (b1<>0)
Then Begin
TextColor (Yellow);
Write (#7);
GoToXY (1,35);
If Error<>0
Then Write ('El dato ingrasado es de tipo incorrecto. ');
GoToXY (1,35);
If b1<>0
Then Write ('Los dias de un mes solo pueden ser del 1 al 31, ambos inclusive.');
GoToXY (1,35);
If (Error<>0) And (b1<>0)
Then Write ('El dato ingresado esta fuera de los par metros permitidos. ')
End
Until (Error=0) And (b1=0);
GoToXY (1,35);
Write (' ': 80)
End;
Procedure LeerMes (Var mn : Integer);
Var Error,b1 : Integer;
mes : String;
Begin
TextColor (Green);
GoToXY (1,11);
Write ('Mes: ');
Repeat
GoToXY (6,11);
TextColor (White);
Write (' ':80);
GoToXY (6,11);
ReadLn (mes);
Error := IOResult; {rara vez ocurrira}
If (mes='enero')Or(mes='febrero')Or(mes='marzo')Or(mes='abril')Or(mes='mayo')Or
(mes='junio')Or(mes='julio')Or(mes='agosto')Or(mes='septiembre')Or
(mes='octubre')Or(mes='noviembre')Or(mes='diciembre')
Then b1:=0
Else b1:=1;
If (Error<>0) Or (b1<>0)
Then Begin
TextColor (Yellow);
GoToXY (1,35);
Write (#7);
If Error<>0
Then Begin
WriteLn ('El dato ingresado es de tipo incorrecto. ');
Write (' ')
End;
If b1<>0
Then Begin
WriteLn ('El dato ingresado esta fuera de los par metros permitidos; adem s,');
Write ('racuerde que el mes debe ser escrito en min£sculas.')
End
End
Until (Error=0) And (b1=0);
If mes='enero' Then mn:= 1;
If mes='febrero' Then mn:= 2;
If mes='marzo' Then mn:= 3;
If mes='abril' Then mn:= 4;
If mes='mayo' Then mn:= 5;
If mes='junio' Then mn:= 6;
If mes='julio' Then mn:= 7;
If mes='agosto' Then mn:= 8;
If mes='septiembre' Then mn:= 9;
If mes='octubre' Then mn:=10;
If mes='noviembre' Then mn:=11;
If mes='diciembre' Then mn:=12;
GoToXY (1,35);
WriteLn (' ':79);
WriteLn (' ':80)
End;
Procedure LeerAnio (Var an : Integer);
Var Error,b1 : Integer;
Begin
TextColor (Green);
GoToXY (1,12);
Write ('A¤o: ');
Repeat
GoToXY (6,12);
TextColor (White);
Write (' ':80);
GoToXY (6,12);
ReadLn (an);
Error := IOResult;
If (1<=an)And(an<=MaxInt)
Then b1:=0
Else b1:=1;
If (Error<>0)Or(b1<>0)
Then Begin
TextColor (Yellow);
Write (#7);
GoToXY (1,35);
If Error<>0
Then Write ('El dato ingresado es de tipo incorrecto. ');
GoToXY (1,35);
If b1<>0
Then Write ('El a¤o ingresado esta fuera del intervalo permitido. ');
GoToXY (1,35);
If (Error<>0)And(b1<>0)
Then Write ('El dato ingresado esta fuera de los par metros permitidos.')
End
Until (Error=0)And(b1=0);
GoToXY (1,35);
Write (' ':80)
End;
Procedure Calendario (mc,ac : Integer;
nc : LongInt);
Var mesc : String;
Begin
Case mc Of
1 : mesc := 'ENERO';
2 : mesc := 'FEBRERO';
3 : mesc := 'MARZO';
4 : mesc := 'ABRIL';
5 : mesc := 'MAYO';
6 : mesc := 'JUNIO';
7 : mesc := 'JULIO';
8 : mesc := 'AGOSTO';
9 : mesc := 'SEPTIEMBRE';
10 : mesc := 'OCTUBRE';
11 : mesc := 'NOVIEMBRE';
12 : mesc := 'DICIEMBRE'
End;
TextColor (Yellow);
GoToXY (25,20);
Write (mesc,' de ',ac,' ');
GoToXY (25,22);
TextColor (Green);
WriteLn ( 'DO LU MA MI JU VI SA');
WriteLn;
TextColor (White);
Case nc Of
0 : Begin
WriteLn (' 1 2 3 4 5 6 7');
WriteLn (' 8 9 10 11 12 13 14');
WriteLn (' 15 16 17 18 19 20 21');
WriteLn (' 22 23 24 25 26 27 28');
WriteLn (' 29 30 31')
End;
1 : Begin
WriteLn (' 1 2 3 4 5 6');
WriteLn (' 7 8 9 10 11 12 13');
WriteLn (' 14 15 16 17 18 19 20');
WriteLn (' 21 22 23 24 25 26 27');
WriteLn (' 28 29 30 31')
End;
2 : Begin
WriteLn (' 1 2 3 4 5');
WriteLn (' 6 7 8 9 10 11 12');
WriteLn (' 13 14 15 16 17 18 19');
WriteLn (' 20 21 22 23 24 25 26');
WriteLn (' 27 28 29 30 31')
End;
3 : Begin
WriteLn (' 1 2 3 4');
WriteLn (' 5 6 7 8 9 10 11');
WriteLn (' 12 13 14 15 16 17 18');
WriteLn (' 19 20 21 22 23 24 25');
WriteLn (' 26 27 28 29 30 31')
End;
4 : Begin
WriteLn (' 1 2 3');
WriteLn (' 4 5 6 7 8 9 10');
WriteLn (' 11 12 13 14 15 16 17');
WriteLn (' 18 19 20 21 22 23 24');
WriteLn (' 25 26 27 28 29 30 31')
End;
5 : Begin
WriteLn (' 1 2');
WriteLn (' 3 4 5 6 7 8 9');
WriteLn (' 10 11 12 13 14 15 16');
WriteLn (' 17 18 19 20 21 22 23');
WriteLn (' 24 25 26 27 28 29 30');
WriteLn (' 31')
End;
6 : Begin
WriteLn (' 1');
WriteLn (' 2 3 4 5 6 7 8');
WriteLn (' 9 10 11 12 13 14 15');
WriteLn (' 16 17 18 19 20 21 22');
WriteLn (' 23 24 25 26 27 28 29');
WriteLn (' 30 31')
End
End
End;
Procedure Salir (Var BS : Char);
Begin
TextColor (Blue);
Write ('¨Desea salir del programa (S/N)? : ');
TextColor (White);
Repeat
BS := ReadKey;
Case BS Of
'S','s' : BS := 's';
'N','n' : BS := 'n'
Else Write (#7)
End
Until (BS='s') Or (BS='n');
WriteLn (BS);
WriteLn;
WriteLn ('*******************************************************************************')
End;
Begin {programa maestro}
Repeat
ClrScr;
Instrucciones_C6_P7;
WriteLn;
d:=0;
m:=0;
a:=0;
LeerDia (d); d:=d1; {realmente no importa el d¡a introducido por el usuario}
LeerMes (m);
LeerAnio(a);
Case m Of
1,2 : n:=a + (31*(m-1)) + d - ((a-1) div 4 ) - ((3*((a+99) div 100)) div 4)
Else n:=a + (31*(m-1)) + d - (((4*m)+23) div 10) - ( a div 4 ) - ((3*((a div 100) + 1)) div 4)
End;
nd:=(n Mod 7);
Calendario (m,a,nd);
WriteLn;WriteLn;WriteLn;
Write ('d:',d,' m:',m,' a:',a, ' nd:',nd);
GoToXY (1,45);
Salir (Salir_SN)
Until Salir_SN='s'
End.