[ Foro de Pascal ]

Duda fichero

29-May-2015 19:52
Invitado (Fran)
1 Respuestas

Necesito poner un control para que solo me deje escribir en entrada 10 caracteres como mucho. Os paso el programa.

 
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;		
 
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:='';
							readln(nn);
							clrscr;
							a1.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 max2:integer);
var
i,z,jj,f:integer;
a1:reg1;
begin
clrscr;
i:=0;
reset(fichero);
i:=filesize(fichero);
if i>0 then begin
jj:=0;
z:=0;
repeat
f:=0;
gotoxy(1,1);
gotoxy(1,2);write('Numero de registros:',i);
writeln;
writeln;
writeln('Autor                Editorial           Cod_Libro   Info                  A-B');
while not eof(fichero) and (z<=6+jj) do begin
read(fichero,a1);
gotoxy(1,5+f);write(a1.autor);
gotoxy(22,5+f);write(a1.edito);
gotoxy(46,5+f);write(a1.cod_libro);
gotoxy(54,5+f);write(a1.lugar);
gotoxy(77,5+f);write(a1.con);
writeln;
inc(z);
inc(f);
end;
jj:=z;
readkey;
clrscr;
until eof(fichero);
end else begin 
writeln('NO HAY DATOS');
delay(500);
end;
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;
var
max2:integer;		
 
begin
		clrscr;
		archivo;
		repeat
			menu;
			case opci of
				1:entrada;
				2:listado(max2);
				3:modifica;
				4:busqueda;
				5:reorga;
				6:archivo;
				end;
		until opci=7;
		writeln;
		writeln;
end.
 




29-May-2015 20:37
Nacho Cabanes (+30)

El fuente resulta muy difícil de leer con tantas tabulaciones tan grandes. Yo te recomendaría usar un editor que te tabule con espacios y poner un tamaño de tabulación de 4 espacios.

El título de tu pregunta habla de ficheros, pero la pregunta en sí parece referirse a entrada por teclado... si quieres que se introduzca por teclado no más de 10 letras para una cadena de texto, tendrás que hacerte una función a propósito, que use ReadKey para leer letra a letra y añadirle tú las condiciones necesarias para que no exceda esa longitud.






(No se puede continuar esta discusión porque tiene más de dos meses de antigüedad. Si tienes dudas parecidas, abre un nuevo hilo.)