Category : File Managers
Archive   : TPMNUS16.ZIP
Filename : PGMNUDRV.PAS

{$I-}
unit PgMnuDrv;
{-------------}
INTERFACE
{-------------}
uses MnuDrv;

procedure PgMenu( FName: MediumStr; var EscKey,F1key,AltXkey: boolean );

{-------------}
IMPLEMENTATION
{-------------}
uses Crt,Dos,Win;
{--------------- initialize global variables -------------}
procedure PgInit;
var i: integer;
p: Pages;
r: RecPtrs;
begin
if ColorMonitor then ScrnAddress := $B800
else ScrnAddress := $B000;
for p := Page0 to Page9 do
for r := RecP1 to RecP10 do
Pg[p,r] := NIL;
NoLines := 0;
Done := False;
Mouse := False;
EscStr := '';
AltxStr := '';
F1Str := '';
CurrentLine := 1;
LocateX := 1;
LocateY := 1;
CustomColor := false;
CustomPos := false;
GetDir(0,CurrentDir);
CurrentDrive := CurrentDir[1] + CurrentDir[2];
CurrentPage := Page0;
CurrentRecPtr := RecP1;
LastPage := Page0;
FirstPage := Page0;
end;

{-----------------------------------------------------}
procedure ChkNewPage;
begin
if CurrentRecPtr = RecP10 then begin
Inc(CurrentPage);
CurrentRecPtr := RecP1;
Inc(LastPage);
end
else Inc(CurrentRecPtr);
end;

{-------- get menu lines from text file --------------}
procedure PgGetMenu(var LineCount: integer;
var MaxChars: integer);
var
M: PgMenuRecPtr;
S_temp: MaxStr;
Code: integer;
Done: Boolean;
HotKey: Char;
i: integer;

begin
Ok := False;
Done := False;
HotKey := '^';
MaxChars := 0;
while not (S_Temp = '[startmenu]') or EOF(f) do
begin
Readln(f,S_Temp);
if not CustomColor then ChkColorInput(S_Temp);
if not CustomPos then ChkMenuPos(S_Temp);
if (Pos('[esckey]',S_Temp) <> 0) then EscStr := S_Temp;
if (Pos('[altxkey]',S_Temp) <> 0) then AltxStr := S_Temp;
if (Pos('[f1key]',S_Temp) <> 0) then F1Str := S_Temp;
end;
if (S_Temp <> '[startmenu]') then Exit;
while not EOF(f) do
begin
Readln(f,S_Temp);
if (Pos(Delimiter,S_Temp) <> 0) then
begin
New(M);
with M^ do
begin
Inc(LineCount);
MenuLine := S_Temp;
case Pos(Delimiter,MenuLine) of
3: Val( MenuLine[2], LineNo, code );
4: Val( MenuLine[2] + MenuLine[3], LineNo, code );
end;
if Code <> 0 then Abort(Msg2);
for i := 1 to Pos(Delimiter,MenuLine) do
Delete(MenuLine,1,1);
StripBlanks(MenuLine);
AltPos := Pos(HotKey,MenuLine);
AltChar := MenuLine[Pos(HotKey,MenuLine) + 1];
Delete(MenuLine,AltPos,1);
if Length(MenuLine) > MaxChars then
MaxChars := Length(MenuLine);
end; { with }
Pg[CurrentPage,CurrentRecPtr] := M;
ChkNewPage;
if LineCount > MaxMenuLines then Abort(Msg4);
end; { if Pos }
end; { while not eof }
Close(f);
CurrentPage := Page0;
CurrentRecPtr := RecP1;
Ok := True;
end;

{------------ set menu window -------------------}
procedure PgGetSetWndow(var Xpos,Ypos: integer);
var i,ActiveLines: integer;
begin
with Wnd do begin
LowerX := Xpos + NoChars + 3;
if LowerX > 79 then begin
Dec(Xpos, (LowerX - 79));
Dec(LowerX, (LowerX - 79));
end;
if NoLines > MaxPgLines then ActiveLines := MaxPgLines
else ActiveLines := NoLines;
LowerY := Ypos + ActiveLines + 1;
if LowerY > 24 then begin
Dec(Ypos, (LowerY - 24));
Dec(LowerY, (LowerY - 24));
end;
UpperX := Xpos;
UpperY := Ypos;
Attrmx := UpperX + NoChars + 1;
Attrmn := UpperX;
end;
end;

{------------------ frame menu window ---------------------}
procedure PgOpenWindow;
var FAttr: byte;
begin
with Wnd do
begin
Shadow;
Window(UpperX,UpperY,LowerX,LowerY);
FrameWin('',DoubleFrame,NormalColor,NormalColor);
FillWin(#0,NormalColor);
FullWin;
if NoLines > MaxPgLines then begin
TextAttr := MsArrowColor;
PgUp.X := LowerX; PgUp.Y := UpperY;
PgDn.X := LowerX; PgDn.Y := LowerY;
if (CurrentPage = FirstPage) then begin
gotoxy(PgDn.X,PgDn.Y); write(#25);
end
else if (CurrentPage = LastPage) then begin
gotoxy(PgUp.X,PgUp.Y); write(#24);
end
else begin
gotoxy(PgUp.X,PgUp.Y); write(#24);
gotoxy(PgDn.X,PgDn.Y); write(#25);
end;
end;
end;
end;

{--------------- get command lines from menu file -----------}
procedure PgGetCmd;
var S_Temp: MaxStr;
Found: boolean;
LineNo,SelectNo: integer;
DeLimiter: Char;
Code: integer;
begin
Found := False;
DeLimiter := ']';
Code := 0;
LineNo := 0;
S_Temp := '';
SelectNo := Pg[CurrentPage,CurrentRecPtr]^.LineNo;
Reset(f);
if IOError('') then Exit;
while not (S_Temp = '[startmenu]') do
readln(f,S_Temp);
while not Found or EOF(f) do
begin
Readln(f,S_Temp);
case Pos(Delimiter,S_Temp) of
3: Val( S_Temp[2], LineNo, code );
4: Val( S_Temp[2] + S_Temp[3], LineNo, code );
5: Val( S_Temp[2] + S_Temp[3] + S_Temp[4], LineNo, code );
end;
if code <> 0 then Abort(Msg2);
if LineNo = SelectNo then Found := True;
end; { with }
if EOF(f) then Abort(Msg3);
while not (S_Temp = '') do
begin
Readln(f,S_Temp);
StripBlanks(S_Temp);
WriteLn(f_Cmd,S_Temp);
end;
Writeln(f_Cmd,CurrentDrive);
Writeln(f_Cmd,'cd ',CurrentDir);
Close(f);
Close(f_Cmd);
if IOError(GetEnv('TPMNU')) then Halt(0);
Done := True;
end;

{---------- write line with normal attributes ---------}
procedure PgWriteNormLine(Line: integer);
var Col: integer;
begin
with Pg[CurrentPage,CurrentRecPtr]^ do begin
for Col := Attrmn to Attrmx do begin { change highlited to normal }
AttrOffset := (((Wnd.UpperY + Line) - 1) * 160) + (Col * 2) + 1;
Mem[VMem:AttrOffset] := NormalColor;
end;
AttrOffset := (((Wnd.UpperY + Line) - 1) * 160) + ((Attrmn + AltPos) * 2) + 1;
Mem[VMem:AttrOffset] := AltColor;
end;
end;

{---------- write highlighted line --------------------}
procedure PgWriteHiLine(Line: integer);
var Col: integer;
begin
with Pg[CurrentPage,CurrentRecPtr]^ do
for Col := Attrmn to Attrmx do begin { highlite next line }
AttrOffset:=(((Wnd.UpperY + Line) - 1) * 160) + (Col * 2) + 1;
Mem[VMem:AttrOffset] := BarColor;
end;
end;

{----------- write menu w/ first menu bar ----------------}
procedure PgWriteMenu;
var Line: integer;
LineNo: integer;
begin
TextAttr := NormalColor;
CurrentRecPtr := RecP1;
if NoLines > MaxPgLines then LineNo := MaxPgLines
else LineNo := NoLines;
for Line := 1 to LineNo do begin
if not (Pg[CurrentPage,CurrentRecPtr] = NIL) then
with Pg[CurrentPage,CurrentRecPtr]^ do begin
gotoxy(Wnd.UpperX + 2,Wnd.UpperY + Line);
write(MenuLine);
AttrOffset := ( ((Wnd.UpperY + Line) - 1) * 160) + ((Attrmn + AltPos) * 2) + 1;
Mem[VMem:AttrOffset] := AltColor;
end;
if (Line < LineNo) and (Pg[CurrentPage,CurrentRecPtr] <> NIL) then
Inc(CurrentRecPtr);
end;
CurrentLine := 1;
CurrentRecPtr := RecP1;
PgWriteHiLine(CurrentLine);
end;

{------------------ move menu bar, up/down --------------------}
procedure PgMoveMenuBar(Up: Boolean);
var Col: integer;
begin
case Up of
MoveUp: if CurrentLine <> 1 then begin
PgWriteNormLine(CurrentLine);
Dec(CurrentLine);
Dec(CurrentRecPtr);
PgWriteHiLine(CurrentLine);
end;
MoveDown: if (CurrentLine <> MaxPgLines) and
(Pg[CurrentPage,Succ(CurrentRecPtr)] <> NIL) then begin
PgWriteNormLine(CurrentLine);
Inc(CurrentLine);
Inc(CurrentRecPtr);
PgWriteHiLine(CurrentLine);
end;
end; { case }
end;

{--------- move menu bar to alternate key response --------}
procedure PgAltMoveMenuBar(NewLine: integer);
var TempRecPtr: RecPtrs;
begin
TempRecPtr := CurrentRecPtr;
Inc(TempRecPtr,(NewLine - CurrentLine));
if (Pg[CurrentPage,TempRecPtr] <> NIL) then begin
HideMouse;
PgWriteNormLine(CurrentLine);
CurrentRecPtr := TempRecPtr;
PgWriteHiLine(NewLine);
CurrentLine := NewLine;
ShowMouse;
PgGetCmd;
end;
end;

{----------- get mouse position and select line ------------}
procedure PgMouseSelect;
var InRangeX,InRangeY,InRange: boolean;
MouseX,MouseY,NewLine: integer;
begin
with Wnd do
begin
MouseX := WhereMouseX;
MouseY := WhereMouseY;
if ((MouseX = PgUp.X) and (MouseY = PgUp.Y))
and (CurrentPage <> FirstPage) then begin
HideMouse;
Dec(CurrentPage);
CurrentRecPtr := RecP1;
PgOpenWindow;
PgWriteMenu;
ShowMouse;
Delay(100);
Exit;
end;
if ((MouseX = PgDn.X) and (MouseY = PgDn.Y))
and (CurrentPage <> LastPage) then begin
HideMouse;
Inc(CurrentPage);
CurrentRecPtr := RecP1;
PgOpenWindow;
PgWriteMenu;
ShowMouse;
Delay(100);
Exit;
end;
{ less confusing boolean breakdown then full evaluation }
InRangeX := (MouseX > (UpperX + 1)) and (MouseX < (LowerX - 1));
InRangeY := (MouseY > UpperY) and (MouseY < LowerY);
InRange := InRangeX and InRangeY;
if not InRange then Exit;
if InRange then
begin
NewLine := MouseY - UpperY;
PgAltMoveMenuBar(NewLine);
end;
end;
end;

{------------ check for alternate key pressed -------------}
procedure PgChkAltKey(AltKey: ScancodeType);
var AltKy: char;
KeyFound: boolean;
NewLine: integer;
RecNo: RecPtrs;
begin
KeyFound := false;
case AltKey of
AltA: AltKy := 'a';
AltB: AltKy := 'b';
AltC: AltKy := 'c';
AltD: AltKy := 'd';
AltE: AltKy := 'e';
AltF: AltKy := 'f';
AltG: AltKy := 'g';
AltH: AltKy := 'h';
AltI: AltKy := 'i';
AltJ: AltKy := 'j';
AltK: AltKy := 'k';
AltL: AltKy := 'l';
AltM: AltKy := 'm';
AltN: AltKy := 'n';
AltO: AltKy := 'o';
AltP: AltKy := 'p';
AltQ: AltKy := 'q';
AltR: AltKy := 'r';
AltS: AltKy := 's';
AltT: AltKy := 't';
AltU: AltKy := 'u';
AltV: AltKy := 'v';
AltW: AltKy := 'w';
AltX: AltKy := 'x';
AltY: AltKy := 'y';
AltZ: AltKy := 'z';
end;
NewLine := 1;
for RecNo := RecP1 to RecP10 do
if Pg[CurrentPage,RecNo] = NIL then Exit
else
with Pg[CurrentPage,RecNo]^ do begin
KeyFound := (Upcase(AltKy) = UpCase(AltChar));
if KeyFound then begin
PgAltMoveMenuBar(NewLine);
Exit;
end;
Inc(NewLine);
end;
end;

{----------- start program main loop ---------------------}
procedure PgMainLoop( Filename: MediumStr;
var EscKeyPressed,F1KeyPressed,AltXKeypressed: boolean);
var Escape,ButtonPressed: boolean;
begin
Escape := false;
repeat
m1 := 3;
m2 := 999;
repeat
PasMouse(m1,m2,m3,m4,m5);
ButtonPressed := (m2 = 1);
until ButtonPressed or KeyPressed;
if ButtonPressed then PgMouseSelect
else
begin
Key := ReadChar;
case Key of
UPKEY :PgMoveMenuBar(MoveUp);
DOWNKEY :PgMoveMenuBar(MoveDown);
ENTER :PgGetCmd;
ESC :Escape := True;
ALTX :begin
done := true;
AltXKeyPressed := True;
end;
F1: begin
F1KeyPressed := True;
Done := True;
end;
PGDNKEY :if CurrentPage <> LastPage then begin
Inc(CurrentPage);
CurrentRecPtr := RecP1;
PgOpenWindow;
PgWriteMenu;
end;
PGUPKEY :if CurrentPage <> FirstPage then begin
Dec(CurrentPage);
CurrentRecPtr := RecP1;
PgOpenWindow;
PgWriteMenu;
end;
else PgChkAltKey(Key);
end; { case }
end;
until Escape or Done;
EscKeyPressed := Escape;
end;

{----------------- close files w/ error check ------------}
procedure PgDisposal;
var NewPage: Pages;
NewRecPtr: RecPtrs;
begin
NewPage := Page0;
NewRecPtr := RecP1;
while not (Pg[NewPage,NewRecPtr] = NIL) do begin
Dispose( Pg[NewPage,NewRecPtr] );
if (NewPage = Page9) and (NewRecPtr = RecP10) then Exit;
if NewRecPtr <> RecP10 then Inc(NewRecPtr)
else begin
Inc(NewPage);
NewRecPtr := RecP1;
end;
end;
end;

{===========================================================================
MAIN
============================================================================}
procedure PgMenu;
begin
PgInit;
ChangeCursor(OFF);
OpenFiles(Fname);
if not Ok then Halt(1);
PgGetMenu(NoLines, NoChars);
if not Ok then Abort(Msg6);
PgGetSetWndow(LocateX,LocateY);
PgOpenWindow;
PgWriteMenu;
if MouseDrv then InitMouse;
ShowPrompts;
PgMainLoop(Fname,EscKey,F1Key,AltXkey);
PgDisposal;
HideMouse;
end;

END. {unit menutool}
{$I+}