Pascal/Turbo Pascal - programacion en pascal

 
Vista:

programacion en pascal

Publicado por maygel (1 intervención) el 11/06/2008 01:17:51
amigos necesito que este programa me maneje una nomina de pago de sueldo
si me ayudan se lo agradeceria ya que lo tengo que entregar el viernes
Program memoria;
Uses crt;
Type
datos = record
Nombre: string [40];
Apodo: string [10];
Mail: string [30];
Telefono: string [20];
SUEL: real;
activo: boolean;
end;
agenda = file of datos;

Var
archivo: agenda;

Procedure pulsar;
begin
writeln;
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
write ('Presione <ENTER> para continuar');
readln;
end;
Procedure Fondo;
var
i,j: byte;
begin
for i:= 1 to 26 do
for j:= 1 to 80 do begin
gotoxy (j,i);
textcolor (9);
write ('Û');
end
end;

Procedure activar (var f: agenda);
var
resultado: integer;
begin
{$I-}
reset (f);
resultado:= IOresult;
{$I+}
if resultado <> 0 then
rewrite (f);
close (f);
end; {activar}

Function Posicion (n: string; var f: agenda): integer;
var
registro: datos;
hallado: boolean;
begin
hallado:= false;
seek (f,0);
while not eof(f) and not hallado do begin
read (f,registro);
hallado:= registro.apodo = n
end;
if hallado then
posicion:= filepos(f) - 1
else
posicion:= -1;
end; {Posicion}

Procedure Visualizar (E: datos);

var
sb,dt,sum:real;

begin
fondo;
textcolor (11);
with e do begin
if E.activo then begin
gotoxy (2,6);write('NOMBRE DEL TRABAJADOR: ');
write (nombre);
writeln;
gotoxy (2,9);write('NUMERO DE LA CEDULA: ');
write (mail);
writeln;
gotoxy (28,12);write('NUMERO DE TELEFONO: ');
writeln (telefono);
gotoxy (28,14);write('NUMERO DE sueldo: ');
writeln (SUEL);

end;
end;

pulsar;
end; {Visualizar}

Procedure LeerRegistro (var E: datos);
var
i: byte;

CONST
MES=30;
VAR
SUEL,SB,DT,DIA:REAL;
begin
textcolor (11);
with E do begin
gotoxy (3,9);
write ('NOMBRE ==> ');
readln (nombre);
for i:= 1 to length (nombre) do
nombre[i]:= upcase (nombre[i]);
writeln;
gotoxy (3,11);
write ('CEDULA ==> ');
readln (apodo);
for i:= 1 to length (apodo) do
apodo[i]:= upcase (apodo[i]);
gotoxy (3,12);
writeln ('ACUERDATE QUE LA CEDULA QUE INTRODUSCA AQUI VA HACER LA MISMA QUE INTRODUSCA ');
gotoxy (3,13);
writeln ('CUANDO QUIERAS BUSCAR, MODIFICAR O ELIMINAR A UN CONTACTO DE LA AGENDA');
writeln;
gotoxy (3,15);
write ('CARGO ==> ');
readln (mail);
writeln;
gotoxy (3,17);
write ('TELEFONO ==> ');
readln (Telefono);
WRITELN('SUELDO BASICO: '); READLN (SB);
WRITELN('DIAS TRABAJADO: '); READLN (DT);
if sb<=0 then
begin
DIA:=(SB / MES);
SUEL:=DIA*DT;
write (' ');
activo:= true;

END;
end; {Leer Registro}
end;
Procedure ampliar (var F: agenda);
var
r,e: datos;
i: integer; {Posicion del registro del archivo}
begin
clrscr;
fondo;
gotoxy (11,3);
textcolor (19);
textcolor (11);
gotoxy (35,3);
writeln ('ZONA DE ALTAS');
reset (f);
writeln;
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln('Pulse cualquier letra menos la "n" o la "N"');
while upcase (readkey) <> 'N' do begin
clrscr;
fondo;
gotoxy (35,3);
textcolor (11);
writeln (' ZONA DE ALTAS ');
writeln;
writeln;
gotoxy (3,6);
writeln ('INTRODUSCA LOS DATOS DEL TRABAJADOR');
leerregistro (E);
I:= Posicion (E.apodo, F);
if I = -1 then begin
i:= filesize (f);
seek (f, I);
write (F, E);
end
else begin
seek (F, I);
read (F, R);
if R.activo then begin
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('Ya existe un trabajador con ese nombre');
writeln;
pulsar;
end
else
write (F, E);
end;
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('Pulse "N" si quiere salir de la zona de altas');
end;
close (F);
end; {Ampliar}

Procedure Borrar (var F: agenda);
var
E: datos;
N: string;
I: Integer;
begin
reset (F);
repeat
clrscr;
fondo;
gotoxy (11,3);
textcolor (19);
write ('*****************************');
textcolor (11);
gotoxy (35,3);
writeln ('ZONA DE BAJAS');
reset (F);
writeln;
writeln;
textcolor (9);
gotoxy (1,6);
write ('ÛÛÛ');
textcolor (11);
write ('INTRODUSCA LA CEDULA DEL TRABAJADOR A BORRAR ==> ');
readln (N);
for i:= 1 to length (n) do
n[i]:= upcase (n[i]);
I:= Posicion (N, F);
if I = -1 then begin
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('NO SE ENCUENTRA TRABAJADO EN ESTA EMPRESA');
pulsar;
end
else begin
seek (F, I);
read (F, E);
if E.activo then begin
visualizar (E);
E.activo:= false;
I:= Filepos (F) - 1;
seek (F, I);
write (F, E);
end;
writeln;
textcolor (9);
gotoxy (1,6);
write ('ÛÛÛ');
textcolor (11);
writeln ('EL TRABAJADOR FUE DADO DE BAJAS');
writeln;
pulsar;
end;
writeln;
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('Pulse "N" para salir de la zona de bajas');
until upcase (readkey) = 'N';
close (f);
end; {Borrar}

Procedure Modificar (var F: agenda);
var
E: datos;
N: string;
I: integer;
begin
reset (F);
repeat
clrscr;
fondo;
gotoxy (11,3);
textcolor (19);
write ('*******************');
textcolor (11);
gotoxy (35,3);
writeln ('ZONA DE MODIFICACIONES');
writeln;
textcolor (9);
gotoxy (1,7);
write ('ÛÛÛ');
textcolor (11);
write ('INTRODUSCA LA CEDULA DEL TRABAJADOR ==> ');
readln (n);
for i:= 1 to length (n) do
n[i]:= upcase (n[i]);
I:= Posicion (N, F);
if I = -1 then begin
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
write ('NO TRABAJA EN ESTA EMPRESA');
pulsar;
end
else begin
seek (F, I);
read (F, E);
if E.activo then begin
clrscr;
fondo;
visualizar (E);
writeln;
clrscr;
fondo;
gotoxy (1,4);
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('INTRODUSCA LOS NUEVOS DATOS DEL TRABAJADOR');
LeerRegistro (E);
I:= Filepos (f) - 1;
seek (F, I);
write (F, E);
writeln;
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('REGISTRO MODIFICADO');
end
else begin
writeln;
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('EL TRABAJADOR FUE DADO DE BAJA');
end
end;
writeln;
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('Pulse "N" para salir de la zona de modificaciones');
until upcase (readkey) = 'N';
close (F);
end; {Modificar}

Procedure Consultar (var F: agenda);
var
E: datos;
N: string;
I: Integer;
begin
reset (F);
repeat
clrscr;
fondo;
gotoxy (11,3);
textcolor (19);
write ('***************************');
textcolor (11);
gotoxy (35,3);
writeln ('ZONA DE CONSULTAS');
writeln;
textcolor (9);
gotoxy (1,6);
write ('ÛÛÛ');
textcolor (11);
write ('INTRODUSCA LA CEDULA DEL EL TRABAJADOR A CONSULTAR ==> ');
readln (N);
for i:= 1 to length (n) do
n[i]:= upcase (n[i]);
I:= Posicion (N, F);
if I = -1 then begin
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('NO TRABAJA EN ESTA EMPRESA');
pulsar;
end
else begin
seek (F, I);
read (F, E);
if E.activo then begin
clrscr;
visualizar (E);
end
else begin
writeln;
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('EL TRABAJADOR FUE DADO DE BAJA');
writeln;
pulsar;
end
end;
textcolor (9);
write ('ÛÛÛ');
textcolor (11);
writeln ('Pulse "N" si desea salir de la zona de consultas');
until upcase (readkey) = 'N';
close (F);
end; {Modificar}

Procedure Menu (var f: agenda);
var
opcion: char;
begin
repeat
clrscr;
fondo;
textbackground (0);
gotoxy (10,3);
textcolor (19);
delay (45);
write ('************************');
textcolor (11);
gotoxy (33,3);
textbackground (8);
writeln (' MENé PRINCIPAL ');
writeln;
writeln;
textcolor (11);
writeln;
gotoxy (3,6);
delay (45);
writeln ('1.- AGREGAR UN TRABAJADOR');
writeln;
gotoxy (3,8);
delay (45);
writeln ('2.- MODIFICAR LA INFORMACION DE UN CONTACTO');
writeln;
gotoxy (3,10);
delay (45);
writeln ('3.- BUSCAR UN TRABAJADOR');
writeln;
gotoxy (3,12);
delay (45);
writeln ('4.- DESPEDIR A UN TRABAJADOR');
writeln;
gotoxy (3,14);
delay (45);
writeln ('5.- SALIR');
writeln;
writeln;
gotoxy (3,17);
delay (45);
write ('ESCRIBA LA OPCION QUE DECEA EJECUTAR ==> ');
repeat
opcion:= readkey
until opcion in ['1'..'5'];
clrscr;
case opcion of
'1': ampliar (F);
'2': Modificar (F);
'3': Consultar (F);
'4': Borrar (f);
end
until opcion = '5';
end; {Menu}

Begin {Principal}
clrscr;
assign (archivo, 'c:contacto.dat');
activar (archivo);
menu (archivo);
End.
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder

RE:programacion en pascal

Publicado por Diego Romero (996 intervenciones) el 11/06/2008 22:50:53
¿Y dónde está el problema? :S
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar