home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / DD11.ZIP / CLUSTER.INC next >
Encoding:
Text File  |  1989-04-18  |  2.3 KB  |  95 lines
  1.  Function ClusterNumber: word;
  2.  type
  3.   FnameType = array[0..7] of Char;
  4.   FextType = array[0..2] of Char;
  5.  
  6.   DTArec =
  7.     record
  8.       DOSnext : array[1..21] of Byte;
  9.       attr : Byte;
  10.       fTime, fDate, flSize, fhSize : Integer;
  11.       FullName : array[1..13] of Char;
  12.     end;
  13.  
  14.   UnopenedFCBrec =
  15.     record
  16.       flag : Byte;
  17.       junk : array[0..4] of Byte;
  18.       SearchAttr : Byte;
  19.       drive : Byte;
  20.       fName : FnameType;
  21.       fExt : FextType;
  22.       attr : Byte;
  23.       DOSnext : array[12..21] of Byte;
  24.       fTime, fDate, fCluster, flSize, fhSize : word;
  25.     end;
  26.  
  27.  var
  28.   FCB : UnopenedFCBrec;
  29.   dta : DTArec;
  30.   FCBreturn : UnopenedFCBrec absolute dta;
  31.   reg : registers;
  32.   SearName: string;
  33.   SearExt : string;
  34.   DriveNumber:byte;
  35.   place :byte;
  36.  
  37.   procedure SetDTA(var dta : DTArec);
  38.   begin
  39.     reg.ah := $1A;
  40.     reg.ds := Seg(dta);
  41.     reg.dx := Ofs(dta);
  42.     MsDos(reg);
  43.   end;
  44.  
  45.   procedure InitFCB(var FCB : UnopenedFCBrec; driveNum : Byte;
  46.                     name, ext : String; sattr : Byte);
  47.   begin
  48.     FillChar(FCB, SizeOf(FCB), 32);
  49.     with FCB do begin
  50.       flag := $FF;
  51.       SearchAttr := sattr;
  52.       drive := driveNum;
  53.       Move(name[1], fName, Length(name));
  54.       if Length(ext) > 0 then
  55.         Move(ext[1], fExt, Length(ext));
  56.     end;
  57.   end;
  58.  
  59.  begin
  60.    DriveNumber:=Ord(Upcase(DriveLetter))-64;
  61.    getdir(DriveNumber,SearName);
  62.    SearName := JustFileName(SearName);
  63.    SearExt  := JustExtension(SearName);
  64.    Place:=Pos('.',SearName);
  65.    If Place > 0 then
  66.        Delete(Searname,Place,Length(SearName));
  67.    {$I-}
  68.    Chdir(DriveLetter+':');
  69.    If IOResult<>0 then Writeln('Error setting drive ',IoResult);
  70.    Chdir('..');
  71.    {$I+}
  72.    If IOResult=0 then
  73.      SearchMode := Cluster
  74.    else
  75.      begin
  76.        SearchMode   := Root;
  77.        ClusterNumber:= RootBegin;
  78.        exit;
  79.      end;
  80.    SetDTA(dta);
  81.    {      drive C, some dir,   dir attr}
  82.    InitFCB(FCB, DriveNumber, SearName,SearExt, $10);
  83.    FillChar(FCBreturn, SizeOf(FCBreturn), 0);
  84.    reg.ah := $11;
  85.    reg.ds := Seg(FCB);
  86.    reg.dx := Ofs(FCB);
  87.    MsDos(reg);
  88.    {$I-}
  89.    chdir(SearName+'.'+SearExt);
  90.    {$I+}
  91.    If IOResult<>0 then Writeln('Error setting dir ',IoResult);
  92.    if reg.al = $FF then WriteLn('Error in XFCB ');
  93.    ClusterNumber:=FCBreturn.fCluster;
  94.   end; { function ClusterNumber }
  95.