Questo sito utilizza cookies solo per scopi di autenticazione sul sito e nient'altro. Nessuna informazione personale viene tracciata. Leggi l'informativa sui cookies.
Username: Password: oppure
Pascal - Mi aiutate per piacere a fare questo programma???
Forum - Pascal - Mi aiutate per piacere a fare questo programma???

Avatar
Ocentral (Normal User)
Pro


Messaggi: 86
Iscritto: 25/12/2009

Segnala al moderatore
Postato alle 10:20
Sabato, 26/12/2009
Program Criptatore;
uses crt,dos;
var nome:string[20]; pass:string;      s1:pathstr ;
procedure codifica(Nomefile,password:string);

const
maxbuf=3000;
var
base1,base2:byte;
sorg,dest:file;
buffer:array[1..maxbuf]of byte;
byteletti:real;
i:integer;
i1,i2:byte;
rr:integer;

procedure aprifile;
const
s:array[1..6] of char =('L','O','C','K','E','D');
BEGIN
   assign(sorg,s1);
   {$I-}
   reset (sorg,1);
   {$I+}
   if ioresult<>0 then
   begin
   writeln('File non trovato');
   write('Premere invio per terminare');
   readln;
   halt;
   end;

blockread(sorg,buffer,6,rr);
if ((buffer[1]=ord('L'))and
    (buffer[2]=ord('O'))and
    (buffer[3]=ord('C'))and
    (buffer[4]=ord('K'))and
    (buffer[5]=ord('E'))and
    (buffer[6]=ord('D'))) then
begin
writeln('File già crittografato...');
write('Premere invio per terminare.......');
readln;
halt;
end;

reset(sorg,1);

assign(dest,'$$$$$.$$');
rewrite(dest,1);
blockwrite(dest,s,6);
blockwrite(dest,base1,1);
blockwrite(dest,base2,1);
end;

{***********************}

procedure prendibase;
var
   i,j:integer;
begin
gotoxy(1,6);
write('Scrivere la password');
readln(pass);
base1:=0;
base2:=0;

j:=length(password);
for i:=1 to length(password) do
   begin
     base1:=base1+(ord(password) * i);
     base2:=base2+(ord(password) * j);
     j:=j-1;
   end;
end;


{***********************************}


procedure chiudifile;
var
i:integer;
begin
rr:=0;
rewrite(sorg,1);
fillchar(buffer,maxbuf,0);
while byteletti>0 do
  begin
   if byteletti>maxbuf then
    blockwrite(sorg,buffer,maxbuf)
   else
         begin
           i:=trunc(byteletti);
           blockwrite(sorg,buffer,i);
         end;
   byteletti:= byteletti-maxbuf;
end;
close(sorg);
close(dest);
erase(sorg);
rename(dest,paramstr(1));
end;

begin {codifica}
prendibase;
aprifile;
i1:=base1;
i2:=base2;
byteletti:=0;
blockread(sorg,buffer,maxbuf,rr);
byteletti:=byteletti+rr;
while rr > 0 do
begin
  for i:=1 to rr do
   begin
     i1:=i1-i;
     i2:=i2+i;
     if odd(i) then
       buffer:= buffer - i1
     else
        buffer:= buffer +i2;
   end;
  blockwrite(dest,buffer,rr);
  blockread(sorg,buffer,maxbuf,rr);
  byteletti:= byteletti+rr;
  end;
chiudifile;
end; {endcodifica}

{*************************************************************}

procedure decodifica(nomefile, password:string);

const
maxbuf=3000;
var
base1,base2,base1x,base2x:byte;
sorg,dest:file;
buffer:array[1..maxbuf]of byte;
byteletti:real;
i:integer;
i1,i2:byte;
rr:integer;

procedure aprifile;
const
s:array[1..6] of char =('L','O','C','K','E','D');
BEGIN
   assign(sorg,nomefile);
   {$I-}
   reset (sorg,1);
   {$I+}
   if ioresult<>0 then
   begin
   writeln('File non trovato');
   write('Premere invio per terminare');
   readln;
   halt;
   end;
blockread(sorg,buffer,6);
if not ((buffer[1]=ord('L'))and
    (buffer[2]=ord('O'))and
    (buffer[3]=ord('C'))and
    (buffer[4]=ord('K'))and
    (buffer[5]=ord('E'))and
    (buffer[6]=ord('D'))) then
begin
writeln('File non crittografato...');
write('Premere invio per terminare.......');
readln;
halt;
end;

blockread(sorg,base1x,1);
blockread(sorg,base2x,1);

if ((base1<>base1x) or (base2<>base2x)) then
begin
   writeln('Password Sbagliata.');
   writeln('Premere invio per terminare.....');
   readln;
   halt;
end;

assign(dest,nomefile+'.$$');
rewrite(dest,1);
end;

procedure prendibase;
var
   i,j:integer;
begin
gotoxy(1,6);
write('Scrivere la password');
readln(pass);
base1:=0;
base2:=0;

j:=length(password);
for i:=1 to length(password) do
   begin
     base1:=base1+(ord(password) * i);
     base2:=base2+(ord(password) * j);
     j:=j-i;
   end;
end;
procedure chiudifile;
var
i:integer;
begin
rewrite(sorg,1);
fillchar(buffer,maxbuf,0);
while byteletti>0 do
  begin
   if byteletti>maxbuf then
    blockwrite(sorg,buffer,maxbuf)
   else
         begin
           i:=trunc(byteletti);
           blockwrite(sorg,buffer,i);
         end;
   byteletti:= byteletti-maxbuf;
end;
close(sorg);
close(dest);
erase(sorg);
rename(dest,paramstr(1));
end;

begin {Decodifica}
prendibase;
aprifile;
i1:= base1;
i2:=base2;
byteletti:=0;
blockread(sorg,buffer,maxbuf,rr);
byteletti:=byteletti+rr;
while rr>0 do
  begin
   for i:=1 to rr do
    begin
     i1:=i1-i;
     i2:=i2+i;
     if odd(i) then
      buffer := buffer +i1
      else
       buffer := buffer - i2;
     end;
   blockwrite(dest,buffer,rr);
   blockread(sorg,buffer,maxbuf,rr);
  end;
chiudifile;
end;


{*******************************************************}

procedure Menu;
var c:char;  v:byte;
begin
v:=0;
gotoxy(10,1);
write('Programma di codifica/decodifica');
gotoxy(10,5);
write('C)Codifica');
gotoxy(10,6);
write('D)Decodifica');
gotoxy(10,7);
write('E)Esci');
gotoxy(25,8);
readln(c);



     begin
   case upcase(c) of
     'C':
      begin
       clrscr;
       v:=1;
       gotoxy(10,1);
       write('Programma di codifica scritto da Cuayankees');
       gotoxy(1,4);
       write('Scrivere nome file inclusa l''estensione');
       readln(nome);
        S1 := FSearch(nome,'c:\users\cuacentral\desktop');
  if S1= '' then
    Writeln('file non trovato')
  else
    Writeln('file trovato nel percorso= ',FExpand(S1));

       Codifica(nome,pass);
     end;

     'D':
      begin
       v:=1;
       clrscr;
       gotoxy(10,1);
       write('Programma di decodifica scritto da Cuayankees');
       gotoxy(1,4);
       write('Scrivere nome file inclusa l''estensione');
       readln(nome);
         S1 := FSearch(nome,'c:\users\cuacentral\desktop');
  if S1= '' then
    Writeln('file non trovato')
  else
    Writeln('file trovato nel percorso= ',FExpand(S1));
       Decodifica(nome,pass);
      end;

      'E':
      begin
       v:=1;
       clrscr;
       write('Premere invio per finire');
       readln;
       halt;
      end;
    end;
    if  v = 0 then
    begin
      write('Inserire bene i dati!!!');
      gotoxy(25,8);
      end;




end;

  end;

begin
clrscr;
menu;
readln;
end.



Ultima modifica effettuata da Ocentral il 26/12/2009 alle 10:29
PM Quote
Avatar
Pippo_94 (Normal User)
Rookie


Messaggi: 32
Iscritto: 18/05/2009

Segnala al moderatore
Postato alle 10:29
Sabato, 26/12/2009
Dovresti specificare la consegna che devi svolgere e in quale errore sei incappato.

PM Quote
Avatar
Ocentral (Normal User)
Pro


Messaggi: 86
Iscritto: 25/12/2009

Segnala al moderatore
Postato alle 11:10
Sabato, 26/12/2009
Il fatto e' che non sempre mi torva i files che voglio.
E pensare che ci sto lavorando da due settimane!!!

PM Quote
Avatar
Anonymous (Member)
Guru


Messaggi: 1060
Iscritto: 30/07/2006

Segnala al moderatore
Postato alle 13:08
Sabato, 26/12/2009
non sei stato per niente chiaro.....

ricomincia da capo, magari specificando per filo e per segno quello che dovrebbe fare il programma, e quello che non fa ecc ecc....

non puoi pretendere che ci studiamo il tuo codice per poi dirti quello che non va senza che tu ci abbia fornito alcuna spiegazione...

Ultima modifica effettuata da Anonymous il 26/12/2009 alle 13:08
PM Quote