Zjistí velikost a volnou kapacitu dostupných disků

{ DISKINFO.PAS              Copyright (c) TrSek alias Zdeno Sekerak }
{  Program vypise do suboru, ci na obrazovku (parameter /h)         }
{  velkosti jednotlivych diskov, ktore su dostupne na PC            }
{  spolu s ich charkteristikov :                                    }
{    F - Floppy disk                                                }
{    L - Hard disk, ci iny fyzicky paskvil na PC                    }
{    N - Net disk                                                   }
{                                                                   }
{ Datum:30.01.1998                             http://www.trsek.com }
 
program zisti_disky;
uses crt,dos;
const open_vyluc='disk.no';                     { subor obsahuje vymenovane subory }
                                                { ktore nema testovat }
      sub_res='disks.tab';                      { subor obsahuje velkosti jednotlivych diskov }
 
var i:integer;                                  
    dis:array[0..26] of boolean;
    poc_dis:byte;
    help:boolean;
    f:text;
    devka:string;
 
function typ_disku(disk:byte):char;             { Aky typ disku }
                                                { F - floppy }
                                                { L - hard disk, ci ine v PC }
                                                { N - netdisk, sietovy disk }
var reg:registers;
begin
 if not (disk in [1,2]) then begin              { Ak to nie je disketa }
    Reg.Ah:=$44;
    Reg.Al:=$0F;
    Reg.Bl:=disk;
    Intr($21,Reg);                              { Zisti ci sa disk da citat }
    if Reg.Ah<>0 then dis[disk-1]:=false
       else begin
        Reg.Ah:=$44;
        Reg.Al:=$09;
        Reg.Bl:=disk;
        Intr($21,Reg);                          { Je to sietovy disk ? }
        if (Reg.DX and $1000)=$1000 then typ_disku:='N'
                                    else typ_disku:='L';
       end;
   end
    else typ_disku:='F';                        { Je to floppy disk ! velmi sa s tym nebabrem }
end;
 
procedure diskety;                              { Kolko ma disketovych mechanik }
var Reg:registers;
begin
 Intr($11,Reg);
 if (Reg.AX and $c0)=0 then dis[1]:=false;      { Ma len jednu mechaniku takze nema B ... asi ! }
 if (Reg.AX and 1)=0 then dis[0]:=false;        { Nema ziadnu mechaniku, takze nema A ... asi ! }
end;
 
procedure vylucit;                              { V subore open_vyluc vymenovane }
var f:text;                                     { disky, ktore nema testovat }
    ch:char;
begin
 Assign(f,open_vyluc);
 {$I-}
 ReSet(f);
 {$I+}
 if IOResult=0 then begin
    repeat
     Read(f,ch);
     ch:=UpCase(ch);
     if (ch in ['A'..'Z']) then dis[ord(ch)-ord('A')]:=false;
    until (eof(f));
    close(f);
   end;
end;
 
function sstr( cislo:longint; kolko:byte ):string;      { sprav z cisla retazec. Joj Pascal }
var pret:string;
begin
 str(cislo:kolko,pret);
 sstr:=pret;
end;
 
procedure fWriteLn( tex:string );                       { vypise na obrazovku, alebo do suboru }
begin
 if help then WriteLn(tex)
         else WriteLn(f,tex);
end;
 
begin
 for i:=0 to ord('z')-ord('a')+1 do dis[i]:=true;
 poc_dis:=0;help:=false;
 diskety;                               { ake su diskety ??? }
 vylucit;                               { ake disky netestovat ? }
 
 if ParamCount>0 then begin
    devka:=ParamStr(1);
    if devka[2] in ['?','h','H'] then help:=true;
   end;
 
                                        { prejdi ci mozes testovat ! }
 for i:=1 to ord('z')-ord('a') do begin
     if dis[i] then
        if DiskSize(i+1)<0 then dis[i]:=false
                           else inc(poc_dis);
    end;
 
 
 if not(help) then begin
     Assign(f,sub_res);
     {$I-}
     ReWrite(f);
     {$I+}
     if IOResult<>0 then halt(4);
    end;
 
                                        { Urob result svojej prace }
 fWriteLn(sstr(poc_dis,0)+'   disks  [ Size ]       [ Free ]');
 
 for i:=0 to ord('z')-ord('a') do begin
     if dis[i] then
        if DiskSize(i+1)>-1 then begin
           fWriteLn( chr(ord('A')+i) + ':  ' + typ_disku(i+1) + sstr(DiskSize(i+1),14) +' '+ sstr(DiskFree(i+1),14) )
           end
          else begin
           if i=0 then
              fWriteLn( chr(ord('A')+i) + ':  ' + typ_disku(i+1) + sstr(1440000,14) +' '+ sstr(0,14) )
           end;
    end;
 
 fWriteLn('');
 fWriteLn('Software by TRSEK alias Zdeno Sekerak, Trnkov 18, Presov, 082 12');
 fWriteLn('V subore '+open_vyluc+' mozno vymenovat disky ktore nema testovat.');
 if not(help) then close(f);
end.