[Back to FILES SWAG index] [Back to Main SWAG index] [Original]
{
File select menu unit. Something like a FileListBox unit.
You can select a file from a listbox and change directory or disk if
needed (and allowed by the programmer: see the Attribut propertie.)
Remarks
-------
The (Y1 - Y0) value must be greater than 15. This means that the
number of columns of the file select window must be at least of
16 characters.
The flTouche will be used in order to know which key the user has
pressed (13 for Enter key, 59 for F1 key, and so on)
The Escape key or F10 key will terminate the selection without any
filename in return of the function
ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
º º°
º AVONTURE CHRISTOPHE º°
º AVC SOFTWARE º°
º BOULEVARD EDMOND MACHTENS 157/53 º°
º B-1080 BRUXELLES º°
º BELGIQUE º°
º º°
ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ°
°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
This is one of my very best unit. Please send me a postcard if you find
it usefull. Thanks in advance!
==> Hey, is there somebody in the United States of America? I have <==
==> received postcard from severall country but none from the States <==
==> Be the first! <==
}
Unit FileList;
Interface
Const FlTouche : Byte = 0; { Key that the user has pressed }
FName : String = ''; { Selected filename }
Type Str14 = String[14];
FileListP = Record
X0, X1, Y0, Y1 : Byte; { Window coordinates }
TAttr : Byte; { Color of the window }
TBarre : Byte; { Color of the select bar }
Masque : Str14; { Mask - *.*, *.BAT, ... }
Attribut : Word; { File attribut: only files matching this }
{ attribut will be displayed }
ChgRep : Boolean; { Do we must return to the original path? }
End;
{ The only public function. }
Function GetFName (Donnees : FileListP) : String;
Implementation
Uses Crt, Dos;
Type TCadre = Array [1..8] of Char;
Const Double : Tcadre = ('É','Í','»','º','º','È','Í','¼');
MaxFich = 1024; { Max number of displayed file }
Var NbrFich : Byte; { File number per line }
NbrF : Byte; { Working variable }
NbrFRep : Word; { Number of file find in the directory }
TabF : Array [1..MaxFich] of Str14; { The directory... }
I, J : Byte;
DosFich : SearchRec;
Rep : Byte;
Disque : Byte;
MaxF : Byte;
X_Barre : Byte;
Y_Barre : Byte;
wPos : Byte;
TBack : Byte;
Complet : Boolean; { Is there several screen? }
RepAct : String;
{ This function will return True if the disk exist, false otherwise }
Function Disque_Exist (Disq: Byte) : Boolean; Assembler;
Asm
Push Ds
Cmp Disq, 2 { Test if this is a floppy drive }
Jbe @@A_or_B
Mov Ax, 4409h { Hard disk or network one? }
Mov Bl, Disq
Int 21h
Jc @@False
Mov Ax, 1
Jmp @@Fin
@@A_or_B: Mov Ah, 44h
Mov Al, 0Eh
Mov Bl, Disq
Int 21h
Cmp Al, Disq
Jnz @@False
Mov Ax, 1
Jmp @@Fin
@@False: Mov Ax, 1500h { Test if the disk is a CD }
Mov Bx, 0000h
Int 2Fh
Xor Ax, Ax
Cmp Bx, 0
Jz @@Fin
Inc Cl
Cmp Cl, [Disq]
Jne @@Fin
Mov Ax, 1
@@Fin: Pop Ds
End;
{ Write a string at the specified screen coordinates and with the given
color attribut
}
Procedure WriteStrXY (X, Y, TAttr, TBack : Word; Texte : String);
Var Offset : Word;
i : Byte;
Attr : Word;
Begin
offset := Y * 160 + X Shl 1;
Attr := ((TAttr+(TBack Shl 4)) shl 8);
For i:= 1 to Length (Texte) do Begin
MemW[$B800:Offset] := Attr or Ord(Texte[i]);
Inc (Offset,2);
End;
End;
{ Return the full filename }
Function TrueName (FName : String) : String;
Var Temp : String;
Regs : Registers;
Begin
FName := FName + #0;
Regs.Ah := $60;
Regs.Ds := Seg(FName);
Regs.Si := Ofs(FName[1]);
Regs.Es := Seg(Temp);
Regs.Di := Ofs(Temp[1]);
Intr ($21, Regs);
DosError := Regs.Ax * ((Regs.Flags And FCarry) shr 7);
Temp[0] := #255;
Temp[0] := Chr (Pos(#0, Temp) - 1);
If DosError <> 0 then
Temp := '';
TrueName := Temp;
end;
{ Read a character on the screen at the specified coordinates
}
Procedure ReadCar (X, Y : word;Var Attr : Byte; Var Carac : Char);
var Car : ^char;
Attribut : ^Byte;
Begin
New (car);
Car := ptr ($B800,(Y*160 + X Shl 1));
Carac := car^;
New (attribut);
Attribut := ptr ($B800,(Y*160 + X Shl 1 + 1));
Attr := attribut^;
End;
{ Draw a cadre
}
Procedure Cadre (ColD, LigD, ColF, LigF, Attr, Back : Byte; Cad : TCadre);
Var
X, Y, I, Longueur, Hauteur : Byte;
sLine : String;
Begin
X := WhereX; Y := WhereY;
Longueur := (ColF-ColD)-1;
Hauteur := (LigF-LigD)-1;
WriteStrXy (ColD, LigD, Attr, Back, Cad[1]);
FillChar (sLine[1], Longueur, Cad[2]);
sLine [0] := Chr(Longueur);
WriteStrXy (ColD+1, LigD, Attr, Back, sLine);
WriteStrXy (ColD+1+Longueur, LigD, Attr, Back, Cad[3]);
For i:= 1 To Hauteur Do Begin
WriteStrXy (ColD, LigD+I, Attr, Back, Cad[4]);
FillChar (sLine[1], Longueur, ' ');
sLine [0] := Chr(Longueur);
WriteStrXy (ColD+1, LigD+I, Attr, Back, sLine);
WriteStrXy (ColD+1+Longueur, LigD+I, Attr, Back, Cad[5]);
End;
WriteStrXy (ColD, LigF, Attr, Back, Cad[6]);
FillChar (sLine[1], Longueur, Cad[7]);
sLine [0] := Chr(Longueur);
WriteStrXy (ColD+1, LigF, Attr, Back, sLine);
WriteStrXy (ColD+1+Longueur, LigF, Attr, Back, Cad[8]);
GotoXy (X, Y);
End;
{ Fill the TabF array with the name of each file found in the directory
}
Procedure SearchCurrentDir (Masque : Str14; Attribut : Word);
Begin
FillChar (TabF, SizeOf (TabF), ' '); { Initialize the array }
I := 1; Disque := 0;
If Disque_Exist (1) then Begin TabF[I] := '[A:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (2) then Begin TabF[I] := '[B:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (3) then Begin TabF[I] := '[C:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (4) then Begin TabF[I] := '[D:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (5) then Begin TabF[I] := '[E:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (6) then Begin TabF[I] := '[F:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (7) then Begin TabF[I] := '[G:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (8) then Begin TabF[I] := '[H:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (9) then Begin TabF[I] := '[I:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (10) then Begin TabF[I] := '[J:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (11) then Begin TabF[I] := '[K:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (12) then Begin TabF[I] := '[L:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (13) then Begin TabF[I] := '[M:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (14) then Begin TabF[I] := '[N:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (15) then Begin TabF[I] := '[O:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (16) then Begin TabF[I] := '[P:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (17) then Begin TabF[I] := '[Q:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (18) then Begin TabF[I] := '[R:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (19) then Begin TabF[I] := '[S:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (20) then Begin TabF[I] := '[T:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (21) then Begin TabF[I] := '[U:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (22) then Begin TabF[I] := '[V:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (23) then Begin TabF[I] := '[W:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (24) then Begin TabF[I] := '[X:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (25) then Begin TabF[I] := '[Y:..]'; Inc (I); Inc (Disque); End;
If Disque_Exist (26) then Begin TabF[I] := '[Z:..]'; Inc (I); Inc (Disque); End;
{ Test if we can show path name or only file? }
If ((Attribut and 16) = 16) then Begin { We can show path name }
Rep := 0;
FindFirst ('*.*', 16, DosFich);
FindNext (DosFich);
While DosError = 0 do Begin
If (DosFich.Attr and Directory = Directory) then Begin
{ We have found a directory }
TabF[I] := '<'+DosFich.Name+'>';
Inc (I);
Inc (Rep);
End;
FindNext (DosFich);
End;
End;
{ Clear the attribute bit of Directory only }
Attribut := Attribut and not 16;
{ Test if we can show file name or not }
If Not (Attribut = 0) then Begin { We can show file name }
FindFirst (Masque, Attribut, DosFich);
While DosError = 0 do Begin
If Not (DosFich.Attr and Attribut = 0) then Begin
TabF[I] := DosFich.Name;
Inc (I);
End;
FindNext (DosFich);
End;
End;
NbrFRep := I - 1;
End;
{ Write the filename or the path name
}
Procedure Prompt (X , Y, TAttr : Byte; Option : Str14);
Begin
GotoXY (X,Y);
WriteStrXy (X, Y, TAttr, 0, Option);
End;
{ Give the possibility to the user to select a name. }
Function MChoix (X0, Y0, X1, Y1, X, Y, TAttr, TBarre : Byte) : String;
{ Handle the select bar
}
Procedure SurBrillance (X, TBarre : Byte);
Var Attribut : Word;
Offset : Word;
i : Byte;
Lig : Str14;
Attr : Byte;
Chh : Char;
Begin
offset := Y * 160 + X * 2;
Lig := '';
For I := 0 to 12 Do Begin
ReadCar (X+I, Y, Attr, Chh);
Lig := Lig + Chh;
End;
For i:= 1 to 13 do Begin
MemW[$B800:Offset] := (TBarre shl 8) or Ord(Lig[I]);
Inc (Offset,2);
End;
End;
{ Construct the screen with the bar and the file/path name
}
Procedure Affiche (X0, Y0 : Byte; Depart : Word);
Begin
GotoXy (0,2); NbrF := 0; wPos := Depart;
X_Barre := X0+2; Y_Barre := Y0+1;
For J := Depart to (Depart+(MaxF*NbrFich)-1) do Begin
If Not (J > NbrFRep) then Prompt (X_Barre, Y_Barre, TAttr, TabF[J]+' ')
Else Prompt (X_Barre, Y_Barre, TAttr, ' ');
Inc (NbrF);
If Not (NbrF < NbrFich) then Begin
Inc (Y_Barre);
X_Barre := X0 + 2;
NbrF := 0;
End
Else Inc (X_Barre, 13);
End;
End;
{ Main of MChoix function }
Var
Ch : Char;
Begin
GotoXy (X, Y);
wPos := 1;
SurBrillance (X, TBarre);
Repeat
Ch := Readkey; If Ch = #0 then Ch := Readkey;
SurBrillance (X, TAttr);
Case Ch Of
#72 : Begin {UpKey}
If Complet then Begin
If (wPos - NbrFich - 1 < NbrFRep) then Begin
Dec (Y); Dec (wPos, NbrFich);
End;
End
Else
If ((Y-1 = Y0) and (Not (wPos - 1 < NbrFich))) then Begin
wPos := wPos - (((X - X0) Div 13));
Affiche (X0, Y0, Abs(wPos-(NbrFich*MaxF)));
X := X0 + 2;
Y := Y0 + 1;
End
Else If Not (wPos - NbrFich - 1 < 0) then Begin
Dec (Y); Dec (wPos, NbrFich);
End
Else If Not (wPos - 1 > NbrFRep) then Begin
If (wPos - NbrFich - 1 < NbrFRep) then Begin
Dec (Y); Dec (wPos, NbrFich);
End;
End;
End;
#80 : Begin {DownKey}
If Complet then Begin
If (wPos + NbrFich -1 < NbrFRep) then Begin
Inc (Y); inc (wPos, NbrFich);
End
End
Else
If (wPos + NbrFich - 1 < NbrFich*MaxF) then Begin
Inc (Y); inc (wPos, NbrFich);
End
Else If (Y+1 = Y1) then Begin
wPos := wPos - (((X - X0) Div 13));
Affiche (X0, Y0, wPos+NbrFich);
X := X0 + 2;
Y := Y0 + 1;
End
Else If Not (wPos + 1 > NbrFRep) then Begin
If (wPos + NbrFich - 1< NbrFRep) then Begin
Inc (Y); inc (wPos, NbrFich);
End;
End;
End;
#77 : Begin {Right}
If Complet then Begin
If Not (wPos+1 > NbrFRep) then Begin
If Not (X + 13 > (X0+(NbrFich-1)*(13)+2)) then Begin
Inc (X, 13); Inc (wPos);
End
Else If Not (Y > Y0 + (NbrFRep Div NbrFich)) then Begin
X := X0 + 2; Inc (Y); Inc (wPos);
End;
End
End
Else Begin
If Not (wPos+1 > NbrFich*MaxF) then Begin
If Not (X + 13 > (X0+(NbrFich-1)*(13)+2)) then Begin
Inc (X, 13); Inc (wPos);
End
Else If Not (Y > Y0 + (NbrFich*MaxF Div NbrFich)) then Begin
X := X0 + 2; Inc (Y); Inc (wPos);
End;
End
Else If ((Y+1 = Y1) and ((((X - X0) Div 13 ) + 1) = NbrFich)) then Begin
Affiche (X0, Y0, wPos+1);
X := X0 + 2;
Y := Y0 + 1;
End
Else If Not (wPos + 1 > NbrFRep) then Begin
If Not (X + 13 > (X0+(NbrFich-1)*(13)+2)) then Begin
Inc (X, 13); Inc (wPos);
End
Else If Not (Y > Y0 + (NbrFich*MaxF Div NbrFich)) then Begin
X := X0 + 2; Inc (Y); Inc (wPos);
End;
End;
End
End;
#75 : Begin {Left}
If Complet then Begin
If Not (X = X0+2) then Begin
Dec (X, 13); Dec (wPos);
End
Else If Not (Y < Y0 + 2) then Begin
X := X0+((NbrFich-1)*(13)+2);
Dec (Y); Dec (wPos);
End;
End
Else
If ((Y-1 = Y0) and ((((X - X0) Div 13) = 0)) and Not (wPos = 1)) then Begin
wPos := wPos - (((X - X0) Div 13));
Affiche (X0, Y0, Abs(wPos-(NbrFich*MaxF)));
X := X0 + 2;
Y := Y0 + 1;
End
Else If Not (X = X0+2) then Begin
Dec (wPos); Dec (X, 13);
End
Else If Not (Y < Y0 + 2) then Begin
X := X0+((NbrFich-1)*(13)+2);
Dec (Y); Dec (wPos);
End;
End;
End;
GotoXy (X, Y);
SurBrillance (X, TBarre);
{ Only Enter key, Escape key or Function key (F1-F10) can stopped
the selection
}
Until (Ch in [#13, #27, #59..#68]);
{ FLTouche retains the value of the pressed key }
FLTouche := Ord(Ch);
{ If the pressed key is not F10 or Escape then return the filename }
If ((Ch = #27) or (Ch = #68)) then MChoix := ''
Else MChoix := TabF[wPos];
End;
{ The only function public.
}
Function GetFName (Donnees : FileListP) : String;
Var FinJ : Word;
NomRep : String;
Begin
TBack := TextAttr;
With Donnees Do Begin
TextAttr := TAttr;
{ The window must be at least 17 columns great }
If (X1 - X0 < 16) then X1 := X0 + 16;
{ Process the number of file per line }
NbrFich := ((( X1 - X0) - 2) Div 13);
Repeat
{ Show the current directory }
SearchCurrentDir (Masque, Attribut);
MaxF := Y1 - Y0 - 1;
{ Draw a cadre on the screen
}
Cadre (X0, Y0, X1, Y1, (TAttr And $F), (TAttr Shr 4), Double);
X_Barre := X0 + 2;
Y_Barre := Y0 + 1;
NbrF := 0;
If (NbrFRep > MaxF * NbrFich) then Begin
FinJ := MaxF*NbrFich;
Complet := False;
End
Else Begin
FinJ := NbrFRep;
Complet := True;
End;
For J := 1 to FinJ do Begin
Prompt (X_Barre, Y_Barre, TAttr, TabF[J]);
Inc (NbrF);
If Not (NbrF < NbrFich) then Begin
Inc (Y_Barre);
X_Barre := X0 + 2;
NbrF := 0;
End
Else Inc (X_Barre, 13);
End;
{ Give the possibility to the user to select a file/path name or
another disk }
FName := MChoix (X0, Y0, X1, Y1, X0+2, Y0+1, TAttr, TBarre);
gotoxy (0,0);
If Not ((FLTouche = 27) or (FLTouche = 68)) then Begin
If Not (wPos > Disque + Rep) then Begin
{ The user has pressed the Enter key on a disk specification or
on a path name }
FName := ''; FLTouche := 0;
End;
If Not (wPos > Disque) then Begin
{ Change the active disk }
NomRep := Copy (TabF[wPos], 2, 2);
{$I-}
ChDir (NomRep);
{$I+}
End
Else If Not (wPos > Disque+Rep) then Begin
{ Change the current path }
NomRep := Copy (TabF[wPos], 2, Length(TabF[wPos]) - 2);
{$I-}
ChDir (NomRep);
{$I+}
End;
End
Else ChDir (RepAct);
Until Not ((FLTouche = 0) and (FName = ''));
{ Return the selected file name }
If Not (FName = '') then GetFName := TrueName (FName)
Else GetFName := FName;
If ChgRep then ChDir (RepAct);
End;
TextAttr := TBack;
End;
Begin
RepAct := TrueName (ParamStr(0)); { Save the current path }
For J := Length (RepAct) Downto 1 do
If RepAct[J] = '\' then Begin
I := J;
J := 1;
End;
RepAct := Copy (RepAct, 1, I-1);
End.
{ ----------------------------- cut here -------------------------------- }
{
Example of the file select menu unit
ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
º º°
º AVONTURE CHRISTOPHE º°
º AVC SOFTWARE º°
º BOULEVARD EDMOND MACHTENS 157/53 º°
º B-1080 BRUXELLES º°
º BELGIQUE º°
º º°
ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ°
°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
}
{ Include the FileList unit }
Uses Crt, Filelist;
{ What you must do: declare a variable based on the FileListP type and
initialized it in your code }
Var FFilelist : FileListP;
NomF : String; { Stored the full name of the selected file }
Begin
ClrScr;
{ If you set the Attribut propertie to "AnyFile - VolumeId - Directoy"
then the user can't change directory. So he must select a file from
the current directory with no possibility to go to other directory or
disk! For a list of value, see the SearchRec function in the DOS
unit: values used by my unit are the same.
Remember that the (Y1 - Y0) value must be greater than 15. If no, the
unit will automatically set the Y1 value to (15 - Y0) + Y1.
The Masque propertie is the DOS match pattern: works exactly like the
SearchRec function.
The TAttr value represent the color -0 to 255- of the window. Exactly
like the Attr CRT variable.
The TBarre value represent the color -0 to 255- of the main bar: the bar
with it you can select a file, directory or drive. Exactly like the Attr
CRT variable.
You the user has select a file (and perhaps changed drive and/or
directory), the ChgRep value specifies to your program if the unit must
go back to the original path after the selection or not. The original
path is the current path just before the GetFName function is called. }
With FFileList Do Begin
X0 := 6; { Size }
X1 := 78; { of }
Y0 := 3; { the }
Y1 := 17; { window }
TAttr := 30; { window color attribut }
TBarre := 57; { bar color attribut }
Masque := '*.*'; { File Mask }
Attribut := $3F-$08; { AnyFile - VolumeId }
ChgRep := True; { Return to original path }
End;
{ Call the filename selector }
NomF := GetFName (FFileList);
{ Here a file has been selected and his full name if stored in NomF. }
ClrScr;
{ And show the selected file name.
A file is select only the user press on the Enter key under the filename.
If the user has pressed the Escape Key or a function key (from F1 to F10),
then the result of the GetFName function is emtpy. So, in this example,
the NomF variable is equal to "" and the flTouche is set to the ASCII
value of the Key: 13 if Enter, 27 if Escape, 59 if F1, 60 if F2, ...
The flTouche variable is declared in the unit so don't declared it again }
Writeln ('Selected file : ',NomF,' ... Key pressed (ASCII value) ',flTouche);
End.
[Back to FILES SWAG index] [Back to Main SWAG index] [Original]