Category : Pascal Source Code
Archive   : DBBROW20.ZIP
Filename : DIRSEL.PAS

unit DIRSEL;
interface

Uses
Crt,Dos; { ** needed for DIRSELECT functions ** }

Function DIRSELECT(mask : string; attr : Integer) : string;

implementation

{ ************************************************************************** }
{ ** List of Procedures/Functions needed for DIRSELECT ** }
{ ** Procedure CURSOR - turns cursor on or off ** }
{ ** Procedure FRAME - draws single or double frame ** }
{ ** Function ISCOLOR - returns the current video mode ** }
{ ** Procedure SAVESCR - saves current video screen ** }
{ ** Procedure RESTORESCR - restores old video screen ** }
{ ** Procedure SCRGET - get character/attribute ** }
{ ** Procedure SCRPUT - put character/attribute ** }
{ ** Procedure FNAMEPOS - finds proper screen position ** }
{ ** Procedure HILITE - highlights proper name ** }
{ ** Function DIRSELECT - directory selector ** }
{ ** ** }
{ ** Modifications ** }
{ ** 5/22/88 Allows more than 120 directory entries (Mark Winkler) ** }
{ ************************************************************************** }

Const
off = false;
on = true;
maxdir = 400; { max number of directorys allowed must be => 120 }

var

fudge : integer;


Procedure CURSOR( attrib : Boolean );
Var
regs : Registers;
Begin
If NOT attrib Then { turn cursor off }
Begin
regs.ah := 1;
regs.cl := 7;
regs.ch := 32;
Intr($10,regs)
End
Else { turn cursor on }
Begin
Intr($11,regs);
regs.cx := $0607;
If regs.al AND $10 <> 0 Then regs.cx := $0B0C;
regs.ah := 1;
Intr($10,regs)
End
End;

Procedure FRAME(t,l,b,r,ftype : Integer);
Var
i : Integer;
Begin
GoToXY(l,t);
If ftype = 2 Then
Write(Chr(201))
Else
Write(Chr(218));
GoToXY(r,t);
If ftype = 2 Then
Write(Chr(187))
Else
Write(Chr(191));
GoToXY(l+1,t);
For i := 1 To (r - (l + 1)) Do
begin
If ftype = 2 Then Write(Chr(205))
Else
Write(Chr(196));
end;
GoToXY(l+1,b);
For i := 1 To (r - (l + 1)) Do
begin
If ftype = 2 Then Write(Chr(205))
Else
Write(Chr(196));
end;
GoToXY(l,b);
If ftype = 2 Then
Write(Chr(200))
Else
Write(Chr(192));
GoToXY(r,b);
If ftype = 2 Then
Write(Chr(188))
Else
Write(Chr(217));
For i := (t+1) To (b-1) Do
Begin
GoToXY(l,i);
If ftype = 2 Then
Write(Chr(186))
Else
Write(Chr(179))
End;
For i := (t+1) To (b-1) Do
Begin
GoToXY(r,i);
If ftype = 2 Then
Write(Chr(186))
Else
Write(Chr(179))
End
End;

Function ISCOLOR : Boolean; { returns FALSE for MONO or TRUE for COLOR }
Var
regs : Registers;
video_mode : Integer;
equ_lo : Byte;
Begin
Intr($11,regs);
video_mode := regs.al and $30;
video_mode := video_mode shr 4;
Case video_mode of
1 : ISCOLOR := FALSE; { Monochrome }
2 : ISCOLOR := TRUE { Color }
End
End;

Procedure SAVESCR( Var screen );
Var
vidc : Byte Absolute $B800:0000;
vidm : Byte Absolute $B000:0000;
Begin
If NOT ISCOLOR Then { if MONO }
Move(vidm,screen,4000)
Else { else COLOR }
Move(vidc,screen,4000)
End;

Procedure RESTORESCR( Var screen );
Var
vidc : Byte Absolute $B800:0000;
vidm : Byte Absolute $B000:0000;
Begin
If NOT ISCOLOR Then { if MONO }
Move(screen,vidm,4000)
Else { else COLOR }
Move(screen,vidc,4000)
End;

Procedure SCRGET( Var ch,attr : Byte );
Var
regs : Registers;
Begin
regs.bh := 0;
regs.ah := 8;
Intr($10,regs);
ch := regs.al;
attr := regs.ah
End;

Procedure SCRPUT( ch,attr : Byte );
Var
regs : Registers;
Begin
regs.al := ch;
regs.bl := attr;
regs.ch := 0;
regs.cl := 1;
regs.bh := 0;
regs.ah := 9;
Intr($10,regs);
End;

Procedure FNAMEPOS(Var arypos,x,y : Integer);
{ determine position on screen of filename }
Const
FPOS1 = 1;
FPOS2 = 14;
FPOS3 = 27;
FPOS4 = 40;
FPOS5 = 53;
FPOS6 = 66;

var
temp : integer;

Begin
temp := arypos - fudge;
y := temp DIV 6;
if temp mod 6 <> 0 then y := succ(y);

Case (temp mod 6) of
1: x := FPOS1;
2: x := FPOS2;
3: x := FPOS3;
4: x := FPOS4;
5: x := FPOS5;
0: x := FPOS6;
end;
End;

Procedure HILITE(old,new : Integer); { highlight a filename on the screen }
Var
i,oldx,oldy,newx,newy : Integer;
ccolor,locolor,hicolor,cchar : Byte;
Begin
FNAMEPOS(old,oldx,oldy); { get position in the array of the filename }
FNAMEPOS(new,newx,newy); { get position in the array of the filename }
For i := 0 To 11 Do
Begin
if old < 32000 then
begin
GoToXY((oldx + i),oldy);
SCRGET(cchar,ccolor);
locolor := ccolor AND $0F;
locolor := locolor shl 4;
hicolor := ccolor AND $F0;
hicolor := hicolor shr 4;
ccolor := locolor + hicolor;
SCRPUT(cchar,ccolor);
end;
GoToXY((newx + i),newy); { reverse video, new selection }
SCRGET(cchar,ccolor);
locolor := ccolor AND $0F;
locolor := locolor shl 4;
hicolor := ccolor AND $F0;
hicolor := hicolor shr 4;
ccolor := locolor + hicolor;
SCRPUT(cchar,ccolor)
End
End;


Function DIRSELECT(mask : string; attr : Integer) : string;
Var
i,oldcurx,oldcury,
newcurx,newcury,
oldpos,newpos,scrrows : integer;
ch : Char;
fileinfo : SearchRec;
screen : Array[1..4000] of Byte;
dos_dir : Array[1..maxdir] of String[12];
rfncnt,fncnt : Integer;

procedure addtop(pos : integer);
var
start,i,newx,dirent : integer;

begin
dirent := pos - fudge;
if dirent > 0 then exit; { nothing to do }
gotoxy(1,1);
insline;
newx := 1;
if (pos mod 6) = 0 then start := pos - 5
else
start := (pos + 1) - (pos mod 6);
for i := start to start + 5 do
begin
gotoxy(newx,1);
write(dos_dir[i]);
newx := newx + 13;
end;
fudge := fudge - 6;
end;

procedure addbottom(pos : integer);
var
start,i,newx,dirent : integer;

begin
dirent := pos - fudge;
if dirent < 121 then exit; { nothing to do }
gotoxy(1,1);
delline;
gotoxy(1,20);
newx := 1;
if (pos mod 6) = 0 then start := pos - 5
else
start := (pos + 1) - (pos mod 6);
for i := start to start + 5 do
begin
if i <= rfncnt then
begin
gotoxy(newx,20);
write(dos_dir[i]);
newx := newx + 13;
end;
end;
fudge := fudge + 6;
end;

Begin
fncnt := 0;
fudge := 0;
findfirst(mask,attr,fileinfo);
If DosError <> 0 Then { if not found, return NULL }
Begin
DIRSELECT := '';
Exit
End;
While (DosError = 0) AND (fncnt <> maxdir) Do { else, collect filenames }
begin
Inc(fncnt);
dos_dir[fncnt] := fileinfo.Name;
FindNext(fileinfo);
end;
rfncnt := fncnt; { save real file count }
oldcurx := WhereX; { store old CURSOR position }
oldcury := WhereY;
SAVESCR(screen);
CURSOR(OFF);
if fncnt > 120 then fncnt := 120;
scrrows := fncnt DIV 6;
if fncnt mod 6 <> 0 then scrrows := succ(scrrows);
window(1,1,80,scrrows + 5);
clrscr;
FRAME(1,1,scrrows + 4,80,2); { draw the frame }
gotoxy(25,scrrows + 3);
write('Select file name (esc = exit)');
window(2,2,79,scrrows+1);
GoToXY(1,1);
i := 1;
While (i <= fncnt) AND (i <= 120) Do { display all filenames }
Begin
FNAMEPOS(i,newcurx,newcury);
GoToXY(newcurx,newcury);
Write(dos_dir[i]);
Inc(i)
End;
HILITE(32000,1); { highlight the first filename }
oldpos := 1;
newpos := 1;
While TRUE Do { get keypress and do appropriate action }
Begin
ch := ReadKey;
Case ch of
#27: { Esc }
Begin
Window(1,1,80,25);
RESTORESCR(screen);
GoToXY(oldcurx,oldcury);
CURSOR(ON);
DIRSELECT := '';
Exit { return NULL }
End;
#72: { Up } { move up one filename }
Begin
i := newpos;
i := i - 6;
If i >= 1 Then
Begin
addtop(i);
oldpos := newpos;
newpos := i;
HILITE(oldpos,newpos)
End
End;
#80: { Down } { move down one filename }
Begin
i := newpos;
i := i + 6;
if i > rfncnt then i := rfncnt;
addbottom(i);
oldpos := newpos;
newpos := i;
HILITE(oldpos,newpos);
End;
#75: { Left } { move left one filename }
Begin
i := newpos;
Dec(i);
If i >= 1 Then
Begin
addtop(i);
oldpos := newpos;
newpos := i;
HILITE(oldpos,newpos)
End
End;
#77: { Right } { move right one filename }
Begin
i := newpos;
Inc(i);
If i <= rfncnt Then
Begin
addbottom(i);
oldpos := newpos;
newpos := i;
HILITE(oldpos,newpos)
End
End;
#13: { CR }
Begin
Window(1,1,80,25);
RESTORESCR(screen);
GoToXY(oldcurx,oldcury); { return old CURSOR position }
CURSOR(ON);
DIRSELECT := dos_dir[newpos];
Exit { return with filename }
End
End
End
End;

Begin
End.