home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / TPFLEX.ZIP / PICKF.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1990-04-24  |  3.0 KB  |  148 lines
  1. {
  2.  
  3.     pickf.pas
  4.     4-25-90
  5.  
  6.     Copyright 1990
  7.     John W. Small
  8.     All rights reserved
  9.  
  10.     PSW / Power SoftWare
  11.     P.O. Box 10072
  12.     McLean, Virginia 22102 8072
  13.     (703) 759-3838
  14.  
  15. }
  16.  
  17. unit pickf;
  18.  
  19. interface
  20.  
  21.     uses dos, pick;
  22.  
  23.     type
  24.  
  25.         PickFile = object(PickList)
  26.             dir : DirStr;
  27.             name : NameStr;
  28.             ext : ExtStr;
  29.             constructor init(path : string);
  30.             procedure   showItem; virtual;
  31.             function    doItem : boolean; virtual;
  32.             destructor  done; virtual;
  33.             end;
  34. {
  35.         PickList = object(FlexList)
  36.             color, mono, attrs : PAptr;
  37.             x, y, rows, cols, clen, startRow,
  38.             crow, ccol : integer;
  39.             update, finished : boolean;
  40.             title : string;
  41.             w : FramedTextWindow;
  42.             constructor init(pdlen,px,py,
  43.                 prows,pcols,pclen : integer;
  44.                 ptitle : string);
  45.             procedure   showItem; virtual;
  46.             function    doItem : boolean; virtual;
  47.             procedure   query;
  48.             destructor  done; virtual;
  49.             end;
  50. }
  51.  
  52. implementation
  53.  
  54.  
  55.     function strcmp(str1, str2 : string) : integer;
  56.         var i  : byte;
  57.         begin
  58.             i := 1;
  59.             while (i <= byte(str1[0])) and
  60.                 (i <= byte(str2[0])) and
  61.                 (str1[i] = str2[i]) do
  62.                 inc(i);
  63.             if i <= length(str1) then
  64.                 if i <= length(str2) then
  65.                     if byte(str1[i]) > byte(str2[i]) then
  66.                         strcmp := 1
  67.                     else
  68.                         strcmp := -1
  69.                 else
  70.                     strcmp := -1
  71.             else if i <= length(str2) then
  72.                 strcmp := 1
  73.             else
  74.                 strcmp := 0
  75.         end;
  76.  
  77.     {$F+}
  78.     function DirEntryCompare(var buf1, buf2) : integer; {$F-}
  79.         var de1 : SearchRec absolute buf1;
  80.             de2 : SearchRec absolute buf2;
  81.         begin
  82.             {$V-}
  83.             DirEntryCompare := strcmp(de1.Name,de2.Name)
  84.             {$V+}
  85.         end;
  86.  
  87.     constructor PickFile.init(path : string);
  88.         var DirEntry : SearchRec;
  89.         begin
  90.             PickList.init(sizeof(SearchRec),10,10,9,4,12,path);
  91.             title := FExpand(title);
  92.             FindFirst(title,Directory,DirEntry);
  93.             while DosError = 0 do begin
  94.                 insSort(DirEntry,DirEntryCompare);
  95.                 FindNext(DirEntry)
  96.                 end
  97.         end;
  98.  
  99.     procedure PickFile.showItem;
  100.         var DirEntryPtr : ^SearchRec;
  101.         begin
  102.             DirEntryPtr := currentD;
  103.             if ok then begin
  104.                 if DirEntryPtr^.Attr = Directory then
  105.                     crt.TextAttr := attrs^[PICK_HILITE_ATTR]
  106.                 else
  107.                     crt.TextAttr := attrs^[PICK_NORMAL_ATTR];
  108.                 write(DirEntryPtr^.Name)
  109.                 end
  110.         end;
  111.  
  112.     function  PickFile.doItem : boolean;
  113.         var DirEntry : SearchRec;
  114.         begin
  115.             get(DirEntry);
  116.             if ok then
  117.                 if DirEntry.Attr = Directory then begin
  118.                     {$V-}
  119.                     if strcmp(DirEntry.name,'.') <> 0 then begin
  120.                         FSplit(title,dir,name,ext);
  121.                         if strcmp(DirEntry.name,'..')  = 0 then begin
  122.                             if length(dir) > 3 then
  123.                                 dir[0] := char(length(dir)-1);
  124.                             FSplit(dir,dir,name,ext);
  125.                             title := concat(dir,'*.*')
  126.                             end
  127.                         else
  128.                             title := concat(dir,DirEntry.name,'\*.*');
  129.                         clear;
  130.                         init(title)
  131.                         end;
  132.                     doItem := false
  133.                     {$V+}
  134.                     end
  135.                 else
  136.                     doItem := true
  137.             else
  138.                 doItem := false
  139.         end;
  140.  
  141.     destructor PickFile.done;
  142.         begin
  143.             PickList.done
  144.         end;
  145.  
  146.     begin
  147.     end.
  148.