4
« en: 17 de Marzo 2020, 14:25 »
este es parte de un programa en pascal anterior. para tener una referencia de lo que quizas se pudiese hacer.
program turismotoursven;
uses
sysutils,dateutils,crt;
{las bibliotecas,sysutils y dateutilis,}
{solucionan de una manera sencilla}
{rutinas relacionadas con fechas}
const
archivo = 'DATOS.dat';
temporal = 'TEMPO.dat';
type
TElturista = record
Numeropas : longint; {numero de pasaporte}
Nombreape : string[60]; {nombre y apellido}
origenpas : char; {origen de pasaporte}
fechapas, {Fecha Exp. pasaporte}
fechavac, {Fecha Exp. certificado vacuna}
fechadec: TDate; {Fecha Exp. declaracion de impuestos}
end;
var
f : file of TElturista; {Archivo maestro}
datos,aux,cop: TElturista; {auxiliares para guardar los datos}
Rmarcado,registro,registro2 :integer; {variables indice}
function existearchivo : boolean;
begin
assign(f,archivo);
{$I-} reset(f); {$I+}
if ioresult = 0 then
existearchivo := true
else
existearchivo := false;
end;
function Expedicion(fecha:TDate) : integer;
begin
DaysBetween(Date,fecha);
end;
{para la solucionar el problema de la vigencia de las fechas}
{se utiliza daysbetween,date and Incyear recordando que }
{un anho tiene 365 o 366 dias y dos anhos tiene 730 o 731 dias}
function anhos(ano:byte) : integer;
begin
DaysBetween(Date,Incyear(Date,-ano));
end;
function existeregistro(var num:longint) : boolean;
var
encontrado: boolean; {Determina la existencia de un registro}
begin
encontrado := false;
for Registro := 0 to filesize(f) - 1 do
begin
seek(f,Registro);
read(f,aux);
if aux.Numeropas = num then
begin
encontrado := true;
Rmarcado := Registro;
break;
end;
end;
if encontrado = true then
existeregistro := true
else
existeregistro := false;
end;
procedure guardardatos(var aux:TElturista);
begin
if existearchivo then
begin
seek(f,filesize(f));
end
else
begin
rewrite(f);
seek(f,0);
end;
write(f,aux);
close(f);
clrscr;
writeln(' Datos guardado Pulse una tecla');
readkey;
end;
procedure mensaje;
begin
writeln(' Nota: Antes de continuar es importante que lea esto: ');
writeln;
textcolor(11);
writeln(' -El campo 1:Nombre y apellido, admite solo letras y espacios. ');
writeln(' -El campo 2:Numero de pasaporte, admite solo numeros. ');
writeln(' -El campo 3:Origen de pasaporte, admite solo una letra V/E. ');
writeln(' -El formato de fecha en los campos 4,5 y 6 es: DD/MM/AAAA . ');
if Monthof(date) in [1..9] then
writeln(' Alternativa 1: DD/','0', MonthOf(date),'/',YearOf(date) )
else
writeln(' Alternativa 1: DD/','', MonthOf(date),'/',YearOf(date) );
writeln(' Alternativa 2: DD/MM/',YearOf(date),' ');
writeln(' Alternativa 3: DD/MM/20AA ' );
textcolor(white);
writeln;
writeln(' Pulse [S] continuar [N] Volver al menu ');
end;
procedure pasaportevalido(var num:longint);
var
strnum:string; {auxiliar del numero de pasaporte}
valido : boolean; {Booleano para validar el campo}
begin
repeat
repeat
readln(strnum);
val(strnum,num);
if num < 1 then
begin
textcolor(yellow);
write(' *Por favor,introduzca solo numeros* : ');
textcolor(white);
end;
until num >= 1;
valido := true;
if existearchivo then
begin
if existeregistro(num) then
begin
valido := false;
textcolor(yellow);
writeln(' Este numero ya esta en el sistema, ');
write(' *vuelva a introducirlo* : ');
textcolor(white);
end;
close(f);
end;
until (valido = true);
end;
procedure origenvalido(var opcion:char);
begin
repeat
opcion:= upcase(readkey);
until opcion in['E','V'];
writeln(opcion);
end;
procedure fechavalida( var fecha:TDate);
var
valido:boolean; {Booleano para validar el campo}
strfecha:string;
begin
repeat
ReadLn(strfecha);
valido:=TryStrToDate(strfecha,fecha);
if valido = false then
begin
textcolor(12);
writeln(' *por favor,fecha en formato DD/MM/AAAA* ');
if Monthof(date) in [1..9] then
writeln(' Alternativa 1: DD/','0', MonthOf(date),'/',YearOf(date) )
else
writeln(' Alternativa 1: DD/','', MonthOf(date),'/',YearOf(date) );
writeln(' Alternativa 2: DD/MM/',YearOf(date),' ');
writeln(' Alternativa 3: DD/MM/20AA ' );
textcolor(yellow);
Write(' Introduzca nuevamente la fecha : ');
textcolor(white);
end;
until valido=true ;
if fecha > incyear(date,50) then
fecha := incyear(fecha,-100);
end;
procedure mostrardatos(var aux:TElturista);
begin
with aux do
begin
writeln(' Nombre y Apellido = ',upcase(Nombreape));
writeln(' Numero de pasaporte = ',numeropas);
writeln(' Origen de pasaporte = ',origenpas);
writeln(' Fecha del pasaporte = ',DatetoStr(fechapas));
writeln(' Fecha Certificado de vacuna = ',DatetoStr(fechavac));
writeln(' Fecha Declaracion de impuestos = ',DatetoStr(fechadec));
writeln;
if (((Expedicion(fechapas)> anhos(1)) and (Origenpas='V')) or
((Expedicion(fechapas) > anhos(2)) and (Origenpas='E')))
or (Expedicion(fechavac) > anhos(1))
or (Expedicion(fechadec) > anhos(1)) then
writeln(' "RECAUDOS NO VIGENTES"');
end;
end;
procedure NombreYapellidovalido(var nomb:string);
type
TAscii = set of #1..#255;
var
alfabeto,espacio:TAscii;
valido : boolean; {Booleano para validar el campo}
caracter : byte;
begin
alfabeto:=[#65..#90,#97..#122,#165..#166];
espacio :=[#32];
repeat
valido := true;
readln(nomb);
for caracter := 1 to length(nomb) do
begin
if nomb[caracter] in alfabeto+espacio then
begin
end
else
begin
valido := false;
break;
end;
end;
if valido = false then
begin
textcolor(yellow);
write(' *Por favor,introduzca solo letras y espacio* : ');
textcolor(white);
end;
until valido = true;
end;
procedure entradadatos;
var
opcion : char; {tecla de opciones}
begin
clrscr;
with datos do
begin
writeln(' ',datetostr(Date));
writeln(' ****** Entrada Datos turista ******');
writeln;
write(' 1) Ingrese Nombre y Apellido : ');
{En este campo solo se admiten letras y/o espacios}
NombreYapellidovalido(nombreape);
write(' 2) Ingrese Numero pasaporte : ');
{En este campo solo se admiten numeros}
{Este campo no admitira 2 numeros de pasaporte iguales}
pasaportevalido(numeropas);
write(' 3) Ingrese Origen del pasaporte [V/E] : ');
{V= Venezolano E=Extranjero}
origenvalido(origenpas);
Write(' 4) Ingrese fecha del Pasaporte : ');
{La fecha debe ser en formato D/M/AA}
fechavalida(fechapas);
Write(' 5) Ingrese fecha del certificado de vacuna : ');
{La fecha debe ser en formato D/M/AA}
fechavalida(fechavac);
Write(' 6) Ingrese fecha de la declaracion de impuestos : ');
{La fecha debe ser en formato D/M/AA}
fechavalida(fechadec);
end;
clrscr;
writeln(' Ha introducido los siguientes datos: ');
writeln;
mostrardatos(datos);
writeln;
writeln(' Desea Guardar Los Datos? ');
writeln;
writeln(' Pulse [S/N]');
repeat
opcion := upcase(readkey);
until opcion in['S','N'];
if opcion = 'S' then
guardardatos(datos);
end;
procedure busqueda;
var
num:longint;
begin
if not existearchivo then
begin
writeln(' Error De Archivo O No Existe Pulse Una Tecla');
readkey;
exit;
end
else
begin
write(' Entre numero de pasaporte : ');
readln(num);
if existeregistro(num) then
begin
writeln;
mostrardatos(aux);
end
else
begin
writeln;
writeln(' No se encuentran datos del turista ');
end;
writeln;
writeln(' Pulse una tecla ');
readkey;
close(f);
end;
end;
procedure ordenar;
{Existe un famoso metodo llamado Burbuja}
{Con este metodo se ordenaran los datos por el numero de pasporte}
begin
if not existearchivo then
begin
writeln(' Error De Archivo O No Existe Pulse Una Tecla');
readkey;
exit;
end
else
begin
for registro := 0 to filesize(f) - 1 do
for registro2 := registro + 1 to filesize(f) - 1 do
begin
seek(f,registro);
read(f,datos);
seek(f,registro2);
read(f,Cop);
if datos.Numeropas > Cop.Numeropas then
begin
Aux := datos;
datos := Cop;
Cop := Aux;
seek(f,registro);
write(f,datos);
seek(f,registro2);
write(f,Cop);
end;
end;
close(f);
end;
end;
procedure modificacion;
var
opcion : char; {tecla de opciones}
num:longint;
begin
clrscr;
if not existearchivo then
begin
writeln(' Error De Archivo O No Existe Pulse Una Tecla');
readkey;
exit;
end
else
begin
write(' Entre numero de pasaporte : ');
readln(num);
if existeregistro(num) then
begin
repeat
clrscr;
with aux do
begin
writeln(' ',Datetostr(Date));
writeln(' **** Modificacion De Datos ****');
writeln;
writeln(' Numero de pasaporte ' ,numeropas);
writeln;
write(' [1] = Nombre y Apellido ') ;textcolor(11);writeln(upcase(Nombreape));textcolor(white);
write(' [2] = Origen del pasaporte ') ;textcolor(11);writeln(origenpas);textcolor(white);
write(' [3] = Fecha del pasaporte ') ;textcolor(11);writeln(DatetoStr(fechapas));textcolor(white);
write(' [4] = Fecha Certificado vacuna ') ;textcolor(11);writeln(DatetoStr(fechavac));textcolor(white);
write(' [5] = Fecha declaracion de impuestos ') ;textcolor(11);writeln(DatetoStr(fechadec));textcolor(white);
writeln(' [6] = finalizar');
writeln;
end;
repeat
opcion := readkey;
until opcion in[#49..#54];
with aux do
case opcion of
#49 : begin
write(' Ingrese Nombre y Apellido : ');
NombreYapellidovalido(Nombreape);
end;
#50 : begin
write(' Ingrese Origen del pasaporte [V/E] : ');
origenvalido(origenpas);
end;
#51 : begin
Write(' Ingrese fecha del Pasaporte : ');
fechavalida(fechapas);
end;
#52 : begin
Write(' Ingrese fecha del certificado de vacuna : ');
fechavalida(fechavac);
end;
#53 : begin
Write(' Ingrese fecha de la declaracion de impuestos : ');
fechavalida(fechadec);
end;
end;
until opcion = #54;
seek(f,Rmarcado);
write(f,aux);
end
else
begin
writeln(' Dato No Encontrado Pulse Una Tecla');
readkey;
end;
close(f);
end;
end;
procedure anularegistro;
var
faux: file of TElturista; {Archivo auxiliar}
opcion : char; {tecla de opciones}
num: longint;
begin
if not existearchivo then
begin
writeln(' Error de Archivo o no existe Pulse Una Tecla');
readkey;
exit;
end
else
begin
write(' Entre numero de pasaporte : ');
readln(num);
if existeregistro(num) then
begin
writeln;
mostrardatos(aux);
writeln;
writeln(' <<< Esta Seguro Que Desea Eliminar Este registro? [S/N] >>>');
repeat
opcion := upcase(readkey);
until opcion in['S','N'];
if opcion = 'S' then
begin
assign(faux,temporal);
rewrite(faux);
for registro := 0 to filesize(f) - 1 do
begin
seek(f,registro);
if registro <> Rmarcado then
begin
read(f,aux);
seek(faux,filesize(faux));
write(faux,aux);
end;
end;
close(f);
close(faux);
erase(f);
rename(faux,archivo);
clrscr;
writeln(' Datos eliminado Pulse una tecla');
readkey;
end;
if opcion = 'N' then
begin
close(f);
end;
end
else
begin
writeln(' Datos no encontrado Pulse una tecla');
readkey;
close(f);
end;
end;
end;
procedure mostrar;
begin
if not existearchivo then
begin
exit;
end
else
begin
writeln(' <<< Listado Ordenado >>> ');
writeln;
While not EOF(f) do
begin
read(f,datos);
if datos.Numeropas <> 0 then
begin
writeln(' ',datos.Numeropas,' ',upcase(datos.Nombreape));
end;
end;
close(f);
writeln;
writeln(' <<< Pulse Una Tecla Para Regresar >>>');
readkey;
end;
end;
procedure contador;
var
vene, {Contador de turistas venezolanos}
extra, {contador de turistas extranjeros}
vacun, {contador de turistas con fecha de vacuna vencida}
impue, {contador de turistas con fecha de declaracion vencida}
recau:integer; {contador de turistas con recaudos vigentes}
begin
if not existearchivo then
begin
writeln(' Error De Archivo O No Existe Pulse Una Tecla ');
readkey;
exit;
end
else
begin
vene := 0;
extra := 0;
vacun := 0;
impue := 0;
recau := 0;
While not EOF(f) do
begin
read(f,datos);
with datos do
if (Numeropas <> 0) then
begin
if (origenpas='V') then
inc(vene);
if (origenpas='E') then
inc(extra);
if (Expedicion(fechavac)>anhos(1)) then
inc(vacun);
if (Expedicion(fechadec)>anhos(1)) then
inc(impue);
if (((Expedicion(fechapas)<=anhos(1)) and (Origenpas='V')) or
((Expedicion(fechapas)<=anhos(2)) and (Origenpas='E')))
and (Expedicion(fechavac)<=anhos(1))
and (Expedicion(fechadec)<=anhos(1)) then
inc(recau);
end;
end;
clrscr;
writeln(' <<< Datos>>>');
writeln;
WriteLn(' turistas venezolanos ',vene);
WriteLn(' turistas extranjeros ',extra);
WriteLn(' turistas con c. de vacuna vencido ',vacun);
WriteLn(' turistas con d. de impuestos vencido ',impue);
WriteLn(' turistas con Recaudos vigentes ',recau);
close(f);
writeln;
writeln(' <<< Pulse Una Tecla Para Regresar >>>');
Muchas gracias
Mostrar Mensajes
RSS