home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / DBBROW20.ZIP / DIRSEL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-05-23  |  10.7 KB  |  411 lines
  1. unit DIRSEL;
  2. interface
  3.  
  4. Uses
  5.    Crt,Dos;  { ** needed for DIRSELECT functions ** }
  6.  
  7. Function DIRSELECT(mask : string; attr : Integer) : string;
  8.  
  9. implementation
  10.  
  11. { ************************************************************************** }
  12. { ** List of Procedures/Functions needed for DIRSELECT                    ** }
  13. { ** Procedure CURSOR     - turns cursor on or off                        ** }
  14. { ** Procedure FRAME      - draws single or double frame                  ** }
  15. { ** Function ISCOLOR     - returns the current video mode                ** }
  16. { ** Procedure SAVESCR    - saves current video screen                    ** }
  17. { ** Procedure RESTORESCR - restores old video screen                     ** }
  18. { ** Procedure SCRGET     - get character/attribute                       ** }
  19. { ** Procedure SCRPUT     - put character/attribute                       ** }
  20. { ** Procedure FNAMEPOS   - finds proper screen position                  ** }
  21. { ** Procedure HILITE     - highlights proper name                        ** }
  22. { ** Function DIRSELECT   - directory selector                            ** }
  23. { **                                                                      ** }
  24. { **                          Modifications                               ** }
  25. { **  5/22/88  Allows more than 120 directory entries  (Mark Winkler)     ** }
  26. { ************************************************************************** }
  27.  
  28. Const
  29.    off = false;
  30.    on  = true;
  31.    maxdir = 400;      { max number of directorys allowed must be => 120 }
  32.  
  33. var
  34.  
  35.     fudge                    : integer;
  36.  
  37.  
  38. Procedure CURSOR( attrib : Boolean );
  39. Var
  40.    regs : Registers;
  41. Begin
  42.    If NOT attrib Then { turn cursor off }
  43.    Begin
  44.       regs.ah := 1;
  45.       regs.cl := 7;
  46.       regs.ch := 32;
  47.       Intr($10,regs)
  48.    End
  49.    Else { turn cursor on }
  50.    Begin
  51.       Intr($11,regs);
  52.       regs.cx := $0607;
  53.       If regs.al AND $10 <> 0 Then regs.cx := $0B0C;
  54.       regs.ah := 1;
  55.       Intr($10,regs)
  56.    End
  57. End;
  58.  
  59. Procedure FRAME(t,l,b,r,ftype : Integer);
  60. Var
  61.    i : Integer;
  62. Begin
  63.    GoToXY(l,t);
  64.    If ftype = 2 Then
  65.       Write(Chr(201))
  66.    Else
  67.       Write(Chr(218));
  68.    GoToXY(r,t);
  69.    If ftype = 2 Then
  70.       Write(Chr(187))
  71.    Else
  72.       Write(Chr(191));
  73.    GoToXY(l+1,t);
  74.    For i := 1 To (r - (l + 1)) Do
  75.    begin
  76.         If ftype = 2 Then Write(Chr(205))
  77.         Else
  78.         Write(Chr(196));
  79.    end;
  80.    GoToXY(l+1,b);
  81.    For i := 1 To (r - (l + 1)) Do
  82.    begin
  83.         If ftype = 2 Then Write(Chr(205))
  84.         Else
  85.         Write(Chr(196));
  86.    end;
  87.    GoToXY(l,b);
  88.    If ftype = 2 Then
  89.       Write(Chr(200))
  90.    Else
  91.       Write(Chr(192));
  92.    GoToXY(r,b);
  93.    If ftype = 2 Then
  94.       Write(Chr(188))
  95.    Else
  96.       Write(Chr(217));
  97.    For i := (t+1) To (b-1) Do
  98.    Begin
  99.       GoToXY(l,i);
  100.       If ftype = 2 Then
  101.          Write(Chr(186))
  102.       Else
  103.          Write(Chr(179))
  104.    End;
  105.    For i := (t+1) To (b-1) Do
  106.    Begin
  107.       GoToXY(r,i);
  108.       If ftype = 2 Then
  109.          Write(Chr(186))
  110.       Else
  111.          Write(Chr(179))
  112.    End
  113. End;
  114.  
  115. Function ISCOLOR : Boolean;  { returns FALSE for MONO or TRUE for COLOR }
  116. Var
  117.    regs       : Registers;
  118.    video_mode : Integer;
  119.    equ_lo     : Byte;
  120. Begin
  121.    Intr($11,regs);
  122.    video_mode := regs.al and $30;
  123.    video_mode := video_mode shr 4;
  124.    Case video_mode of
  125.       1 : ISCOLOR := FALSE;  { Monochrome }
  126.       2 : ISCOLOR := TRUE    { Color }
  127.    End
  128. End;
  129.  
  130. Procedure SAVESCR( Var screen );
  131. Var
  132.    vidc : Byte Absolute $B800:0000;
  133.    vidm : Byte Absolute $B000:0000;
  134. Begin
  135.    If NOT ISCOLOR Then  { if MONO }
  136.       Move(vidm,screen,4000)
  137.    Else                 { else COLOR }
  138.       Move(vidc,screen,4000)
  139. End;
  140.  
  141. Procedure RESTORESCR( Var screen );
  142. Var
  143.    vidc : Byte Absolute $B800:0000;
  144.    vidm : Byte Absolute $B000:0000;
  145. Begin
  146.    If NOT ISCOLOR Then  { if MONO }
  147.       Move(screen,vidm,4000)
  148.    Else                 { else COLOR }
  149.       Move(screen,vidc,4000)
  150. End;
  151.  
  152. Procedure SCRGET( Var ch,attr : Byte );
  153. Var
  154.    regs : Registers;
  155. Begin
  156.    regs.bh := 0;
  157.    regs.ah := 8;
  158.    Intr($10,regs);
  159.    ch := regs.al;
  160.    attr := regs.ah
  161. End;
  162.  
  163. Procedure SCRPUT( ch,attr : Byte );
  164. Var
  165.    regs : Registers;
  166. Begin
  167.    regs.al := ch;
  168.    regs.bl := attr;
  169.    regs.ch := 0;
  170.    regs.cl := 1;
  171.    regs.bh := 0;
  172.    regs.ah := 9;
  173.    Intr($10,regs);
  174. End;
  175.  
  176. Procedure FNAMEPOS(Var arypos,x,y : Integer);
  177. { determine position on screen of filename }
  178. Const
  179.    FPOS1 =  1;
  180.    FPOS2 = 14;
  181.    FPOS3 = 27;
  182.    FPOS4 = 40;
  183.    FPOS5 = 53;
  184.    FPOS6 = 66;
  185.  
  186. var
  187.         temp : integer;
  188.  
  189. Begin
  190.    temp := arypos - fudge;
  191.    y := temp DIV 6;
  192.    if temp mod 6 <> 0 then y := succ(y);
  193.  
  194.    Case (temp mod 6) of
  195.         1: x := FPOS1;
  196.         2: x := FPOS2;
  197.         3: x := FPOS3;
  198.         4: x := FPOS4;
  199.         5: x := FPOS5;
  200.         0: x := FPOS6;
  201.         end;
  202. End;
  203.  
  204. Procedure HILITE(old,new : Integer);  { highlight a filename on the screen }
  205. Var
  206.    i,oldx,oldy,newx,newy : Integer;
  207.    ccolor,locolor,hicolor,cchar : Byte;
  208. Begin
  209.    FNAMEPOS(old,oldx,oldy); { get position in the array of the filename }
  210.    FNAMEPOS(new,newx,newy); { get position in the array of the filename }
  211.    For i := 0 To 11 Do
  212.    Begin
  213.           if old < 32000 then
  214.           begin
  215.           GoToXY((oldx + i),oldy);
  216.           SCRGET(cchar,ccolor);
  217.           locolor := ccolor AND $0F;
  218.           locolor := locolor shl 4;
  219.           hicolor := ccolor AND $F0;
  220.           hicolor := hicolor shr 4;
  221.           ccolor  := locolor + hicolor;
  222.           SCRPUT(cchar,ccolor);
  223.       end;
  224.       GoToXY((newx + i),newy);         { reverse video, new selection }
  225.       SCRGET(cchar,ccolor);
  226.       locolor := ccolor AND $0F;
  227.       locolor := locolor shl 4;
  228.       hicolor := ccolor AND $F0;
  229.       hicolor := hicolor shr 4;
  230.       ccolor  := locolor + hicolor;
  231.       SCRPUT(cchar,ccolor)
  232.    End
  233. End;
  234.  
  235.  
  236. Function DIRSELECT(mask : string; attr : Integer) : string;
  237. Var
  238.    i,oldcurx,oldcury,
  239.    newcurx,newcury,
  240.    oldpos,newpos,scrrows : integer;
  241.    ch                   : Char;
  242.    fileinfo             : SearchRec;
  243.    screen               : Array[1..4000] of Byte;
  244.    dos_dir              : Array[1..maxdir] of String[12];
  245.    rfncnt,fncnt         : Integer;
  246.  
  247. procedure addtop(pos : integer);
  248. var
  249.         start,i,newx,dirent : integer;
  250.  
  251. begin
  252.     dirent := pos - fudge;
  253.         if dirent > 0 then exit;     { nothing to do }
  254.         gotoxy(1,1);
  255.         insline;
  256.         newx := 1;
  257.     if (pos mod 6) = 0 then start := pos - 5
  258.         else
  259.     start := (pos + 1) - (pos mod 6);
  260.         for i := start to start + 5 do
  261.         begin
  262.                 gotoxy(newx,1);
  263.                 write(dos_dir[i]);
  264.                 newx := newx + 13;
  265.         end;
  266.         fudge := fudge - 6;
  267. end;
  268.  
  269. procedure addbottom(pos : integer);
  270. var
  271.         start,i,newx,dirent : integer;
  272.  
  273. begin
  274.     dirent := pos - fudge;
  275.         if dirent < 121 then exit;     { nothing to do }
  276.         gotoxy(1,1);
  277.         delline;
  278.         gotoxy(1,20);
  279.         newx := 1;
  280.     if (pos mod 6) = 0 then start := pos - 5
  281.         else
  282.     start := (pos + 1) - (pos mod 6);
  283.         for i := start to start + 5 do
  284.         begin
  285.                 if i <= rfncnt then
  286.                 begin
  287.                 gotoxy(newx,20);
  288.                         write(dos_dir[i]);
  289.                         newx := newx + 13;
  290.                 end;
  291.         end;
  292.         fudge := fudge + 6;
  293. end;
  294.  
  295. Begin
  296.    fncnt := 0;
  297.    fudge := 0;
  298.    findfirst(mask,attr,fileinfo);
  299.    If DosError <> 0 Then   { if not found, return NULL }
  300.    Begin
  301.       DIRSELECT := '';
  302.       Exit
  303.    End;
  304.    While (DosError = 0) AND (fncnt <> maxdir) Do   { else, collect filenames }
  305.    begin
  306.         Inc(fncnt);
  307.         dos_dir[fncnt] := fileinfo.Name;
  308.         FindNext(fileinfo);
  309.    end;
  310.    rfncnt := fncnt;        { save real file count }
  311.    oldcurx := WhereX;     { store old CURSOR position }
  312.    oldcury := WhereY;
  313.    SAVESCR(screen);
  314.    CURSOR(OFF);
  315.    if fncnt > 120 then fncnt := 120;
  316.    scrrows := fncnt DIV 6;
  317.    if fncnt mod 6 <> 0 then scrrows := succ(scrrows);
  318.    window(1,1,80,scrrows + 5);
  319.    clrscr;
  320.    FRAME(1,1,scrrows + 4,80,2);  { draw the frame }
  321.    gotoxy(25,scrrows + 3);
  322.    write('Select file name (esc = exit)');
  323.    window(2,2,79,scrrows+1);
  324.    GoToXY(1,1);
  325.    i := 1;
  326.    While (i <= fncnt) AND (i <= 120) Do     { display all filenames }
  327.    Begin
  328.       FNAMEPOS(i,newcurx,newcury);
  329.       GoToXY(newcurx,newcury);
  330.       Write(dos_dir[i]);
  331.       Inc(i)
  332.    End;
  333.    HILITE(32000,1);            { highlight the first filename }
  334.    oldpos := 1;
  335.    newpos := 1;
  336.    While TRUE Do             { get keypress and do appropriate action }
  337.    Begin
  338.       ch := ReadKey;
  339.       Case ch of
  340.          #27:  { Esc  }
  341.          Begin
  342.             Window(1,1,80,25);
  343.             RESTORESCR(screen);
  344.             GoToXY(oldcurx,oldcury);
  345.             CURSOR(ON);
  346.             DIRSELECT := '';
  347.             Exit                       { return NULL }
  348.          End;
  349.          #72:  { Up   }                { move up one filename }
  350.          Begin
  351.             i := newpos;
  352.             i := i - 6;
  353.             If i >= 1 Then
  354.             Begin
  355.                            addtop(i);
  356.                oldpos := newpos;
  357.                newpos := i;
  358.                HILITE(oldpos,newpos)
  359.             End
  360.          End;
  361.          #80:  { Down }                { move down one filename }
  362.          Begin
  363.             i := newpos;
  364.             i := i + 6;
  365.                 if i > rfncnt then i := rfncnt;
  366.                         addbottom(i);
  367.                         oldpos := newpos;
  368.             newpos := i;
  369.             HILITE(oldpos,newpos);
  370.          End;
  371.          #75:  { Left }                { move left one filename }
  372.          Begin
  373.             i := newpos;
  374.             Dec(i);
  375.             If i >= 1 Then
  376.             Begin
  377.                            addtop(i);
  378.                oldpos := newpos;
  379.                newpos := i;
  380.                HILITE(oldpos,newpos)
  381.             End
  382.          End;
  383.          #77:  { Right }               { move right one filename }
  384.          Begin
  385.             i := newpos;
  386.             Inc(i);
  387.             If i <= rfncnt Then
  388.             Begin
  389.                            addbottom(i);
  390.                oldpos := newpos;
  391.                newpos := i;
  392.                HILITE(oldpos,newpos)
  393.             End
  394.          End;
  395.          #13:  { CR }
  396.          Begin
  397.             Window(1,1,80,25);
  398.             RESTORESCR(screen);
  399.             GoToXY(oldcurx,oldcury);    { return old CURSOR position }
  400.             CURSOR(ON);
  401.             DIRSELECT := dos_dir[newpos];
  402.             Exit                        { return with filename }
  403.          End
  404.       End
  405.    End
  406. End;
  407.  
  408. Begin
  409. End.
  410.  
  411.