{ ARCHIV.PAS                Copyright (c) TrSek alias Zdeno Sekerak }
{ Archivovanie databaz programu zaluzie.                            }
{                                                                   }
{ Datum:19.06.1995                            http://www.trsek.com  }
 
procedure teplomer(kolko,ostava:longint);
const tep_e='ŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰŰ';
      tep_u='źźźźźźźźźźźźźźźźźźźźźźźźźźźźźźźźźźźźźźźź';
var perc:integer;
begin
 perc:=round((kolko/ostava)*100);
 hlaska('Copy ARCHIV.EXE '+copy(tep_u,1,round( perc     /2.5))+
        copy(tep_e,1,round((100-perc)/2.5))+' '+stri(perc,3)+' %',-1);
end;
 
procedure t_copy(subor,subor2,cesta:string);
var ff1,ff2:file;
    quick:pointer;
    naozaj,ostava:longint;
    sub:SearchRec;
    kolko,err:word;
    ch:char;
begin
 ostava:=0;
 if ostava=0 then begin
    Assign  (ff1,subor);
    { $I-}
    ReSet   (ff1,1);
    { $I+}
    if IoResult<>0 then begin hlaska('Archiv nejestvuje na disku.',-1);exit;end;
   end;
 
 Assign  (ff2,cesta+'\'+subor2);
 { $I-}
 ReWrite (ff2,1);
 { $I+}
 if IoResult<>0 then begin hlaska('Nemozny pristup na disk.',-1);exit;end;
 
 FindFirst(subor,Archive or Hidden or ReadOnly,sub);
 if MaxAvail>65535 then kolko:=65535
                   else kolko:=MaxAvail;
 if kolko>sub.size then kolko:=sub.size;
 ostava:=sub.size;naozaj:=kolko;ch:=#0;
 getmem(quick,naozaj);
 teplomer(sub.size-ostava+round(kolko/2),sub.size);
 
 repeat
  BlockRead  (ff1,quick^,kolko,err);
  if keypressed then ch:=readkey;
  if err<>kolko then hlaska('Malo miesta na cielovom disku.',-1);
  teplomer(sub.size-ostava+round(kolko/2),sub.size);
 
  BlockWrite (ff2,quick^,kolko,err);
  if keypressed then ch:=readkey;
  if err<>kolko then exit;
  teplomer(sub.size-ostava+kolko,sub.size);
 
  ostava:=ostava-kolko;
  if kolko>ostava then kolko:=ostava;
 until ((ostava=0) or (ch=#27));
 
 if ostava=0 then close (ff1);
 close (ff2);
 teplomer(sub.size,sub.size);
 freemem(quick,naozaj);
 if (ch=#27) then begin hlaska('Archivacia prerusena uzivatelom.',-1);exit;end;
end;
 
procedure archiv(typ:integer);
var ch,ch1:char;
begin
 if (typ=1) then begin
    repeat
     hlaska('Archiv na disk A B C D',-1);
     ch:=UpCase(readkey);
     if (ch=#27) then begin hlaska('',-2);exit;end;
    until (ch in ['A','B','C','D']);
    hlaska('Archiv na disk '+ch+'  [A/..]',-1);
    ch1:=UpCase(readkey);
    hlaska('',-2);
    if (ch1='A') then begin
       prikaz('pkzip archiv '+dsubor+' '+subor+k_dbf+'>nul');
       prikaz('zip2exe archiv >nul');
{       prikaz('del archiv.zip');}
       prikaz('md '+ch+':\archiv');
       if DosError<>0 then begin
                           hlaska('Disk chraneny proti zapisu, alebo vadny disk.',-1);
                           exit;
                           end;
       t_copy('archiv.exe','archiv.exe',ch+':\archiv');
       prikaz('del archiv.exe');
      end;
    end
    else begin
    repeat
     hlaska('Obnovit archiv z disku A B C D',-1);
     ch:=UpCase(readkey);
     if (ch=#27) then begin hlaska('',-2);exit;end;
    until (ch in ['A','B','C','D']);
    hlaska('Archiv na disk '+ch+'  [A/..]. Obnovit ??? ',-1);
    ch1:=UpCase(readkey);
    hlaska('',-2);
    if (ch1='A') then begin
        t_copy(ch+':\archiv\archiv.exe','archiv.exe','');
        prikaz('archiv.exe -o >nul');
        prikaz('del archiv.exe');
       end;
   end;
 hlaska('',-2);
end;