home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / STAYRESP.ZIP / STAYDEM.410 < prev    next >
Encoding:
Text File  |  1986-06-13  |  6.8 KB  |  181 lines
  1. {----------------------------------------------------------------------------}
  2. {                  F I L E         S U B R O U T I N E S                     }
  3. {----------------------------------------------------------------------------}
  4.   type
  5.     Dir_Entry   = record
  6.                       Reserved : array[1..21] of byte;
  7.                       Attribute: byte;
  8.                       Time, Date, FileSizeLo, FileSizeHi : integer;
  9.                       Name : string[13];
  10.                     end;
  11.   var
  12.     RetCode     : byte;
  13.     Filename  : filename_type;
  14.     Buffer    : Dir_Entry;
  15.  
  16.     Trash        : char;
  17.     attribyte    : byte;
  18.     Xcursor      : integer ;
  19.     Ycursor      : integer ;
  20.  
  21. Procedure Disk_Trns_Addr(var Disk_Buf);
  22.   var segment,offset : integer;
  23. Begin
  24.   segment := seg(Disk_buf);
  25.   offset  := ofs(Disk_buf);
  26.   SetDTA(segment,offset);
  27. end;
  28. {----------------------------------------------------------------------------}
  29. {                  F I N D   N E X T   F I L E   E N T R Y                   }
  30. {----------------------------------------------------------------------------}
  31. Procedure Find_Next(var Att:byte; var Filename : Filename_type;
  32.                                       var Next_RetCode : byte);
  33. var
  34.   Registers  : regtype;
  35.   Carry_flag : integer;
  36.   N          : byte;
  37.  
  38. Begin  {Find_Next}
  39.   Buffer.Name := '             ';     { Clear result buffer }
  40.   with Registers do
  41.       begin
  42.       Ax := $4F shl 8;                 { Dos Find next function }
  43.       MsDos(Registers);
  44.       Att := Buffer.Attribute;         { Set file attribute     }
  45.       Carry_flag := 1 and Flags;       { Isolate the Error flag }
  46.       Filename := '             ';
  47.       if Carry_flag = 1 then
  48.         Next_RetCode := Ax and $00FF
  49.       else
  50.         begin                          { Move file name         }
  51.         Next_RetCode := 0;
  52.         for N := 0 to 12 do FileName[N+1] := Buffer.Name[N];
  53.         end;
  54.     end;  {with}
  55. end;
  56. {----------------------------------------------------------------------------}
  57. {              F I N D   F I R S T   F I L E   F U N C T I O N               }
  58. {----------------------------------------------------------------------------}
  59. Procedure Find_First (var Att: byte;
  60.                       var Filename: Filename_type;
  61.                       var RetCode_code : byte);
  62.  
  63.   var
  64.       Registers        :regtype;
  65.       Carry_flag       :integer;
  66.       N                : byte;
  67.  
  68.   begin
  69.     Disk_Trns_Addr(Buffer);             { Set DTA address }
  70.     Filename[length(Filename) + 1] := chr(0);
  71.     Buffer.Name := '             ';
  72.     with Registers do
  73.       begin
  74.       Ax := $4E shl 8;                  { Dos Find First Function }
  75.       Cx := Att;                        { Attribute of file to fine }
  76.       Ds := seg(Filename);              { Ds:Dx Asciiz string to find }
  77.       Dx := ofs(Filename) + 1;
  78.       MsDos(Registers);
  79.       Att := Buffer.Attribute;          { set the file attribute byte  }
  80.  
  81.         { If error occured set, Return code. }
  82.  
  83.         Carry_flag := 1 and Flags;      { If Carry flag, error occured }
  84.                                         { and Ax will contain Return code }
  85.         if Carry_flag = 1 then
  86.           begin
  87.           RetCode_code := Ax and $00FF;
  88.           end
  89.  
  90.         else
  91.           begin
  92.           RetCode_code := 0;
  93.           Filename := '             ';
  94.           for N := 0 to 12 do FileName[N+1] := Buffer.Name[N];
  95.           end;
  96.  
  97.       end;  {with}
  98. end;
  99. {----------------------------------------------------------------------}
  100. {            G  E  T  F  I  L  E                                       }
  101. {----------------------------------------------------------------------}
  102. Procedure Get_file;
  103. begin
  104.  
  105.       filename := '*.*' ;
  106.       attribyte := 255 ;
  107.  
  108.               Xcursor := 2 ;
  109.               Ycursor := 1 ;
  110.               GotoXy(Xcursor,Ycursor) ;
  111.  
  112.           Find_First(attribyte,filename,Retcode);
  113.               If Retcode = 0 then
  114.                  begin
  115.                  write(Filename);
  116.                  Ycursor := Ycursor +1 ;
  117.                  end;
  118.           {Now we repeat Find_Next until an error occurs }
  119.  
  120.               repeat
  121.                 Find_Next(attribyte,filename,Retcode);
  122.                 if Retcode = 0 then
  123.                  begin
  124.                         GotoXY(Xcursor,Ycursor);
  125.                         Write(filename) ;
  126.                         Ycursor := Ycursor + 1 ;
  127.  
  128.                         if WhereY >= 14 then
  129.                         begin
  130.                         Xcursor := Xcursor + 16 ;
  131.                         Ycursor := 1 ;
  132.                         end;
  133.  
  134.                         if (Xcursor >= 50) and (Ycursor = 13 ) then
  135.                         begin
  136.                         Ycursor := Ycursor + 1;
  137.                         GotoXY(Xcursor,Ycursor);
  138.  
  139.                         Get_Abs_Cursor(x,y);    { Box up More msg..}
  140.                         MkWin(x,y,x+10,y+1,Cyan,black,0); Gotoxy(1,1);
  141.                         Write (' More...');
  142.  
  143.                         While (Not Keypressed) do;
  144.                         Read(Kbd,trash) ;
  145.                         RmWin;                  { Remove "More" window }
  146.  
  147.                         clrscr ;
  148.                         Xcursor := 2 ;
  149.                         Ycursor := 1 ;
  150.                         end;
  151.                  end;
  152.                until Retcode <> 0;
  153.                                        { Make a little Window and hold for }
  154.                                        { user to give us a goose..or whatever}
  155.                GotoXY(Xcursor,Ycursor);
  156.                Get_Abs_Cursor(x,y);        { Get Absolute Cursor Position  }
  157.                MkWin(x,y,x+16,y+1,Cyan,Black,0);   { Put Window at Cursor   }
  158.                GotoXY(1,1);
  159.                Write('Press a key ...');
  160.  
  161.                While (Not Keypressed) do;  { Pause until Key pressed }
  162.                KeyChr := Keyin;            { Read the users Key      }
  163.                RmWin ;                     { Remove the Window       }
  164.                If KeyChr = Quit_Key then   { If Terminate Key then   }
  165.                            Stay_Xit ;      { remove ourself from  Memory }
  166. end;
  167.  
  168. {----------------------------------------------------------------------}
  169. {        D   E  M  O                                                   }
  170. {----------------------------------------------------------------------}
  171. Procedure Demo ;                   { Give Demonstration of Code        }
  172.  
  173.   begin
  174.        KeyChr := #0;               { Clear any residual krap    }
  175.        MkWin(5,5,75,20,Bright+Cyan,Black,3); { Make a Biiiiiiig window}
  176.        Clrscr;                     { Clear screen out           }
  177.        Get_file;                   { Show directory entries     }
  178.        RmWin;                      { Remove the big window      }
  179.   end; { Demo }
  180.  
  181.