Pascal/Turbo Pascal - Control caracteres

Uses crt;

var

  cadena : string;

  c:char;

begin

  clrscr;

  while length(cadena)<15 do

    begin

      c:=readkey;

      write(c);

      cadena:=cadena+c;

    end;

end.

Uses crt;

var

  dato : string;

Procedure entradadatos(var cadena:string);

var

  c:char;

begin

  clrscr;

  while (length(cadena)<15) and (c<>#13) do {con c<>#13 comprobamos que no se haya pulsado intro en cuyo caso                             aunque no se haya llegado al límete daríamos por terminada la captura}

    begin

      c:=readkey;

      write(c);

      cadena:=cadena+c;

    end;

end

begin

  entradadatos(dato);

end.

uses crt,dos;

TYPE

        REG1=RECORD

             Autor:STRING[20];

             Edito:STRING[30];

             Cod_Libro:string[5];

             Lugar:string[30];

             con:char;

        END;

	VAR

			fichero:file of reg1;

			fichcopia:file of reg1;

			OPCION,OPCID:char;

			OPCI,Z,I:INTEGER;

			nf:string[30];

			a:reg1;

			dato:string;

procedure control(var cadena:string; c:char);

begin

clrscr;

while (length(cadena)<5) and (c<>#13) do begin

c:=readkey;

write(c);

cadena:=cadena+c;

end;

end;

procedure conum(var nom1:string;h:integer);

		var

			p:char;

			i1,cc:integer;

	begin

			for i1:=1 to h do begin

                     gotoxy(20+i1,1);

                     write(chr(176));

            end;

			i1:=0;

			cc:=1;

				repeat

					gotoxy(21+i1,1);p:=upcase(readkey);

                   case p of

                       #8:begin

								  i1:=i1-1;

								  if i1<0 then i1:=0;

								  gotoxy(21+i1,1);

								  write(chr(176));

								  cc:=cc-1;

								  if cc<1 then cc:=1;

								  delete(nom1,cc,1);

                          end;

                     #48..#57:begin

									if cc<=h then begin

									  write(p);

									  insert(p,nom1,cc);

									  i1:=i1+1;

									  cc:=cc+1;

									 end;

                              end;

                   end;

                until(p=#13) and (cc>h);

    end;

	PROCEDURE mirarepe(nn:string;VAR vis:INTEGER);

		var pu:integer;

			kk:boolean;

	BEGIN

			reset(fichero);

			pu:=0;

			kk:=true;

		while(pu<filesize(fichero)) and kk do begin

		              read(fichero,a);

                      IF(a.cod_libro=nn) THEN BEGIN

                                        vis:=pu;

										kk:=false;

					  END;

					inc(pu);

        END;

		close(fichero);

	END;

	procedure entrada;

	var

		nn:string[5];

		vis:integer;

		con:char;

		a1:reg1;

	begin

	CON:='S';

	WHILE(CON='S') DO BEGIN

					clrscr;

						repeat

							write(' Dar Autor : ');

							nn:='';

						until nn <>'';

							clrscr;

						repeat

							write('Dar Editorial: ');

							nn:='';

							readln(nn);

							clrscr;

							a1.Edito:=nn;

						until nn <>'';

							clrscr;

						repeat

							write(' Dar Lugar : ');

							nn:='';

							readln(nn);

							clrscr;

							a1.Lugar:=nn;

						until nn <>'';

							clrscr;

							writeln(' Dar Codigo Libro : ');

							nn:='';

								conum(nn,5);

								a1.Cod_libro:=nn;

								a1.con:='a';

								vis:=-22;

									mirarepe(nn,vis);

										if (vis=-22) then begin

												reset(fichero);

												seek(fichero,filesize(fichero));

												write(fichero,a1);

												close(fichero);

												clrscr;

										end

										else writeln('No Valido ');

									writeln;

									write('Mas entradas S - N : ');

									REPEAT

									con:=upcase(readkey);

									UNTIL UPCASE(CON) IN['N','S'];

							END;

						end;

	procedure listado;

		var

		zz,h1:integer;

	begin

				reset(fichero);

				zz:=filesize(fichero);

				clrscr;

				writeln(' LISTADO: ');

				writeln;

		if zz>0 then begin

		h1:=2;

					while(not(eof(fichero)))do begin

							read(fichero,a);

							writeln;

							gotoxy(15,1);

							writeln('Autor:');

							gotoxy(15,h1);

							writeln(a.Autor);

							gotoxy(25,1);

							writeln('Editorial:');

							gotoxy(25,h1);

							writeln(a.Edito);

							gotoxy(38,1);

							writeln('Lugar:');

							gotoxy(38,h1);

							writeln(a.Lugar);

							gotoxy(48,1);

							writeln('CodLibro:');

							gotoxy(48,h1);

							writeln(a.Cod_libro);

							gotoxy(61,1);

							writeln('Alta/Baja:');

							gotoxy(61,h1);

							writeln(a.con);

							inc(h1);

					end;

		end;

		    writeln;

			write('Dar tecla : ');readln;

			close(fichero);

	end;

	procedure modifica;

	var

	 x1,x2:integer;

	 cod2:string[5];

	 nunom:string[20];

	 ok:boolean;

	begin

			reset(fichero);

			clrscr;

			write('Dar Codigo Libro: ');

			cod2:='';

			conum(cod2,5);

			writeln;

			x2:=filesize(fichero);

			x1:=0;

			ok:=true;

			while(x1<x2) and ok do begin

					seek(fichero,x1);

					read(fichero,a);

				if (a.Cod_libro=cod2) then begin

					writeln;

					write('Autor: ',a.Autor);

					writeln;

					repeat

					write('Dar nuevo Autor:');

					readln(nunom);

					clrscr;

					a.Autor:=nunom;

					until nunom <> '';

					writeln;

					write('Editorial: ',a.Edito);

					writeln;

					repeat

					write('Dar nueva editorial:');

					readln(nunom);

					clrscr;

					a.Edito:=nunom;

					until nunom <> '';

					writeln;

					write('Lugar:',a.Lugar);

					writeln;

					repeat

					write('Dar nuevo Lugar:');

					readln(nunom);

					clrscr;

					a.Lugar:=nunom;

					until nunom <> '';

					seek(fichero,x1);

					write(fichero,a);

					ok:=false;

					end;

			inc(x1);

		end;

		writeln;

		write('Dar tecla: '); readln;

		close(fichero);

	end;

	procedure busqueda;

	 var

	 x1,x2:integer;

	 editor:string[30];

	 ok:boolean;

	 l1:char;

	begin

			reset(fichero);

			clrscr;

			write('Dar Editorial: ');

			editor:='';

			readln(editor);

			writeln;

			x2:=filesize(fichero);

			x1:=0;

			ok:=true;

			while(x1<x2) and ok do begin

					seek(fichero,x1);

					read(fichero,a);

				if (a.Edito=editor) then begin

					writeln;

					write('Cambiar Control S :');l1:=upcase(readkey);

						if (l1='S') then begin

					                l1:=a.con;

									case l1 of

											'a':a.con:='b'

											else a.con:='a';

									end;

						end;

					seek(fichero,x1);

					write(fichero,a);

					ok:=false;

				end

				else begin

				inc(x1);

			end;

		end;

		writeln;

		write('Dar tecla: '); readln;

		close(fichero);

	end;

    procedure reorga;

		var zz,l1,posi:integer;

	begin

				reset(fichero);//abrimos fichero con reset

				zz:=filesize(fichero);//filesize numero registro de mi fichero

				clrscr;

				writeln('REORGANIZANDO...');

				WRITELN('#############');

				writeln;

		if zz>0 then begin

		        assign(fichcopia,'Ficopia.dat');

		        rewrite(fichcopia);

		        posi:=0;

		        for l1:=0 to zz-1 do begin

							seek(fichero,l1);

							read(fichero,a);

							if (a.con='a') then begin

											seek(fichcopia,posi);

											write(fichcopia,a);

											inc(posi);

							end;

		        end;

		        close(fichcopia);

		end;

		    writeln;

			write('Fin Reorga Dar tecla : ');readln;

			close(fichero);//siempre cerrar fichero con close

			erase(fichero);

			rename(fichcopia,nf);

	end;

	procedure menu;

		var

			a:array[1..12] of string[20];

	begin

			a[1]:='   (1)   ENTRADA    ';

			A[2]:='   (2)   LISTADO    ';

			A[3]:='   (3)   MODIFICA  ';

			A[4]:='   (4)   BUSQUEDA  ';

			a[5]:='   (5)   REORGA  ';

			a[6]:='   (6)   ESC FICHERO';

			a[7]:='   (7)   FIN        ';

			A[8]:='  MENU - GENERAL    ';

			textbackground(brown);

			clrscr;

			gotoxy(29,4);

			WRITE(A[8]);

			textcolor(7);textbackground(0);

			gotoxy(55,1);

			WRITE('FICHERO -> ',nf);

				for i:=1 to 7 do begin

							 gotoxy(29,5+2*i);

							 write(a[i]);

                end;

				OPCION:=' ';

			WHILE OPCION<>'S'DO BEGIN

							IF OPCI<1 THEN OPCI:=7;

							IF OPCI>7 THEN OPCI:=1;

                 gotoxy(29,5+2*opci);

                textcolor(0);textbackground(7);

                 write(a[opci]);

                textcolor(7);textbackground(0);

                 opcid:=READKEY;

                 z:=opci;

                 CASE OPCID OF

                      #80:OPCI:=OPCI+1;

                      #72:OPCI:=OPCI-1;

                      #49:OPCI:=1;

                      #50:OPCI:=2;

                      #51:OPCI:=3;

                      #52:OPCI:=4;

                      #53:opci:=5;

                      #54:opci:=6;

                      #55:opci:=7;

					  #13:OPCION:='S';

                 END;

                      gotoxy(29,5+2*z);

                      write(a[z]);

            END;

	end;

	procedure controlarch;

	var ok:boolean;

	begin

			gotoxy(35,1);

			WRITE('FICHERO -> ',nf);

			{$I-}

			assign(fichero,nf);

			reset(fichero);

			{$I+}

			ok:=(ioresult=0);

					if not ok then begin

						   clrscr;

						   writeln(' Fichero No existente ');delay(1000);

						   rewrite(fichero);

					end

					else begin

						writeln(' Fichero existente ');delay(1000);

						reset(fichero);

					end;

			close(fichero);

	end;

procedure archivo;

		var

			a:array[1..7] of string[20];

	begin

			a[1]:='Revistas.dat';

			A[2]:='Libros.dat';

			A[3]:='CD.dat';

			A[4]:='Texto.dat';

			a[5]:='Varios.dat';

			A[6]:='  MENU - FICHEROS  ';

			textbackground(brown);

			clrscr;

			gotoxy(27,4);

			WRITE(A[6]);

			textcolor(7);textbackground(0);

				for i:=1 to 5 do begin

							 gotoxy(29,5+2*i);

							 write(a[i]);

                end;

				OPCION:=' ';

			WHILE OPCION<>'S'DO BEGIN

							IF OPCI<1 THEN OPCI:=5;

							IF OPCI>5 THEN OPCI:=1;

                 gotoxy(29,5+2*opci);

                textcolor(0);textbackground(7);

                 write(a[opci]);

                textcolor(7);textbackground(0);

                 opcid:=READKEY;

                 z:=opci;

                 CASE OPCID OF

                      #80:OPCI:=OPCI+1;

                      #72:OPCI:=OPCI-1;

                      #49:OPCI:=1;

                      #50:OPCI:=2;

                      #51:OPCI:=3;

                      #52:OPCI:=4;

                      #53:opci:=5;

                      #13:OPCION:='S';

                 END;

                      gotoxy(29,5+2*z);

                      write(a[z]);

                      case opci of

                        1:nf:=a[1];

                        2:nf:=a[2];

                        3:nf:=a[3];

                        4:nf:=a[4];

                        5:nf:=a[5];

                      end;

            END;

            controlarch;

	end;

begin

		clrscr;

		archivo;

		repeat

			menu;

			case opci of

				1:entrada(dato);

				2:listado;

				3:modifica;

				4:busqueda;

				5:reorga;

				6:archivo;

				end;

		until opci=7;

		writeln;

		writeln;

end.