Category : Pascal Source Code
Archive   : TJOCKOT1.ZIP
Filename : TOTLIST.PAS

 
Output of file : TOTLIST.PAS contained in archive : TJOCKOT1.ZIP
{ Copyright 1991 TechnoJock Software, Inc. }
{ All Rights Reserved }
{ Restricted by License }

{ Build # 1.00 }

Unit totLIST;
{$I TOTFLAGS.INC}

{
Development Notes:


}
INTERFACE

Uses DOS,
totSYS, totLOOK, totFAST, totWIN, totINPUT, totLINK, totSTR, totIO1;

TYPE
tListAction = (Finish,Refresh,None);
ListCharFunc = function(var K:word; var X,Y: byte; HiPick:longint): tListAction;
ListMsgFunc = function(HiPick:longint):string;

pBrowseOBJ = ^BrowseOBJ;
BrowseOBJ = object
vWin: StretchWinPtr;
vTopPick: longint; {number of first pick in window}
vTotPicks: longint; {total number of picks}
vListVisible: boolean; {is list on display}
vListAssigned: boolean; {is data assigned to list}
vActivePick: integer; {the offset of the active pick from the top}
vRows: integer; {total number of visible rows}
vStartCol : longint; {string position of first character}
vEndCol: longint; {rightmost column for scrolling}
vRealColWidth: byte; {max avail column width}
vLastKey: word; {last key the user pressed}
{methods ...}
constructor Init;
procedure SetTopPick(TopPick: longint);
procedure SetStartCol(Column: longint);
procedure SetEndCol(Column: longint);
function Win:StretchWinPtr;
procedure DisplayPick(Pick:integer);
procedure DisplayAllPicks;
procedure ScrollUp;
procedure ScrollDown;
procedure ScrollPgUp;
procedure ScrollPgDn;
procedure ScrollFirst;
procedure ScrollLast;
procedure SlideLeft;
procedure SlideRight;
procedure ScrollFarRight;
procedure ScrollFarLeft;
procedure ScrollJumpH(X,Y:byte);
procedure ScrollJumpV(X,Y:byte);
function LastKey: word;
procedure Remove;
procedure Show;
procedure ResetDimensions;
procedure Go;
function GetString(Pick, Start,Finish: longint):string; VIRTUAL;
destructor Done; VIRTUAL;
end; {BrowseOBJ}

pBrowseArrayOBJ = ^BrowseArrayOBJ;
BrowseArrayOBJ = Object (BrowseOBJ)
vArrayPtr: pointer;
vStrLength: byte;
{methods ...}
constructor Init;
procedure AssignList(var StrArray; Total:Longint; StrLength:byte);
function GetString(Pick, Start,Finish:longint): string; VIRTUAL;
destructor Done; VIRTUAL;
end; {BrowseArrayOBJ}

pBrowseLinkOBJ = ^BrowseLinkOBJ;
BrowseLinkOBJ = Object (BrowseOBJ)
vLinkList: ^DLLOBJ;
{methods ...}
constructor Init;
procedure AssignList(var LinkList: DLLOBJ);
function ListPtr: DLLPtr;
function GetString(Pick, Start,Finish:longint): string; VIRTUAL;
destructor Done; VIRTUAL;
end; {BrowseLinkOBJ}

pBrowseFileOBJ = ^BrowseFileOBJ;
BrowseFileOBJ = Object (BrowseOBJ)
vStrList: ^StrDLLOBJ;
{methods ...}
constructor Init;
function AssignFile(Filename: string):integer;
function ListPtr: StrDLLPtr;
function GetString(Pick, Start,Finish:longint): string; VIRTUAL;
destructor Done; VIRTUAL;
end; {BrowseFileOBJ}

pListOBJ = ^ListOBJ;
ListOBJ = object
vWin: StretchWinPtr; {pointer to a window}
vMargin: tByteCoords; {padding around window border}
vZone: tByteCoords; {outer window dimensions}
vTopPick: longint; {number of first pick in window}
vTotPicks: longint; {total number of picks}
vAllowToggle: boolean; {can user select items in list}
vListVisible: boolean; {is list on display}
vListAssigned: boolean; {is data assigned to list}
vLastChar: word; {last key user pressed}
vColWidth: byte; {user set column width in list display: 0 = max}
vNAttr: byte; {normal attribute/color}
vSAttr: byte; {attribute for special items}
vHAttr: byte; {highlighted topic attribute/color}
vActivePick: integer; {the offset of the active pick from the top}
vRows: integer; {total number of visible rows}
vCols: integer; {Total number of visible columns}
vRealColWidth: byte; {max avail column width}
vLastColWidth: byte; {width of right most column}
vUseLastCol: boolean; {use the last column for highlighting or too narrow}
vLastKey: word; {last key the user pressed}
vCharHook: ListCharFunc; {character hook}
vMsgHook: ListMsgFunc; {message hook}
vMsgActive: boolean; {is Msg hook enabled}
vDualColors: boolean; {should list use SAttr and NAttr}
{methods ...}
constructor Init;
procedure SetTopPick(TopPick: longint);
procedure SetActivePick(ThePick: LongInt);
procedure SetTagging(On:boolean);
procedure SetColors(HAttr,NAttr,SAttr: byte);
procedure SetColWidth(Wid: byte);
procedure SetCharHook(Func:ListCharFunc);
procedure SetMsgHook(Func:ListMsgFunc);
procedure SetMsgState(On:boolean);
procedure SetDualColors(On:Boolean);
function GetHiString:string;
function Win:StretchWinPtr;
procedure ResetDimensions;
procedure DisplayPick(Pick:integer; Hi:boolean);
procedure DisplayAllPicks;
procedure RefreshList;
procedure Remove;
procedure ValidateActivePick;
procedure ScrollUp;
procedure ScrollDown;
procedure JumpEngine(Tot, NewValue: longint);
procedure ScrollJumpV(X,Y:byte);
procedure ScrollJumpH(X,Y:byte);
procedure ScrollLeft;
procedure ScrollFarLeft;
procedure ScrollRight;
procedure ScrollFarRight;
procedure ScrollPgDn;
procedure ScrollPgUp;
procedure ScrollFirst;
procedure ScrollLast;
procedure ToggleSelect;
function TargetPick(X,Y:byte): Integer;
procedure MouseChoose(KeyX,KeyY:byte);

function LastKey: word;
procedure Go;
procedure Show;
function CharTask(var K:word; var X,Y: byte;
HiPick:longint): tListAction; VIRTUAL;
function MessageTask(HiPick:longint):string; VIRTUAL;
function GetString(Pick, Start,Finish:longint): string; VIRTUAL;
function GetStatus(Pick:longint;BitPos:byte): boolean; VIRTUAL;
procedure SetStatus(Pick:longint;BitPos:byte;On:boolean); VIRTUAL;
procedure TagAll(On:boolean); VIRTUAL;
destructor Done; VIRTUAL;
end; {ListOBJ}

pListArrayOBJ = ^ListArrayOBJ;
ListArrayOBJ = object (ListOBJ)
vArrayPtr: pointer;
vStrLength: byte;
vLinkList: ^DLLOBJ;
{methods ...}
constructor Init;
procedure AssignList(var StrArray; Total:Longint; StrLength:byte;Selectable: boolean);
procedure SetTagging(On:boolean);
function GetString(Pick, Start,Finish:longint): string; VIRTUAL;
function GetStatus(Pick:longint;BitPos:byte): boolean; VIRTUAL;
procedure SetStatus(Pick:longint;BitPos:byte;On:boolean); VIRTUAL;
procedure TagAll(On:boolean); VIRTUAL;
destructor Done; VIRTUAL;
end; {of object ListArrayOBJ}

pListLinkOBJ = ^ListLinkOBJ;
ListLinkOBJ = object (ListOBJ)
vLinkList: ^DLLOBJ;
{methods ...}
constructor Init;
procedure AssignList(var LinkList: DLLOBJ);
function ListPtr: DLLPtr;
function GetString(Pick, Start,Finish:longint): string; VIRTUAL;
function GetStatus(Pick:longint;BitPos:byte): boolean; VIRTUAL;
procedure SetStatus(Pick:longint;BitPos:byte;On:boolean); VIRTUAL;
procedure TagAll(On:boolean); VIRTUAL;
destructor Done; VIRTUAL;
end; {ListLinkOBJ}

pListDirOBJ = ^ListDirOBJ;
ListDirOBJ = object (ListOBJ)
vFileList: ^FileDLLOBJ;
vActiveDir: PathStr;
{methods ...}
constructor Init;
procedure ReadFiles(FileMasks:string; FileAttrib: word);
function GetHiString: string;
procedure Go;
function FileList:FileDLLPtr;
function CharTask(var K:word; var X,Y: byte;
HiPick:longint): tListAction; VIRTUAL;
function MessageTask(Hi:longint): string; VIRTUAL;
function GetString(Pick, Start,Finish:longint): string; VIRTUAL;
function GetStatus(Pick:longint;BitPos:byte): boolean; VIRTUAL;
procedure SetStatus(Pick:longint;BitPos:byte;On:boolean); VIRTUAL;
procedure TagAll(On:boolean); VIRTUAL;
destructor Done; VIRTUAL;
end; {ListDirOBJ}

pListDirSortOBJ = ^ListDirSortOBJ;
ListDirSortOBJ = object (ListDirOBJ)
constructor Init;
function PromptAndSort: boolean;
function CharTask(var K:word; var X,Y: byte;
HiPick:longint): tListAction; VIRTUAL;
destructor Done; VIRTUAL;
end; {ListDirSortOBJ}
procedure ListInit;

IMPLEMENTATION
{|||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ M i s c. P r o c s & F u n c s }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||}
{$F+}
function NoCharHook(var K:word; var X,Y: byte; HiPick:longint): tListAction;
{}
begin
NoCharHook := None;
end; {NoCharHook}

function NoMsgHook(HiPick:longint):string;
{}
begin
NoMsgHook := '';
end; {NoEnterHook}
{$IFNDEF OVERLAY}
{$F-}
{$ENDIF}

procedure Error(Err:byte);
{routine to display error}
const
Header = 'totLIST error: ';
var
Msg : string;
begin
Case Err of
1: Msg := 'A list Must be assigned before calling SHOW or GO';
else Msg := 'Unknown Error';
end; {case}
Writeln(Header,Msg);
{Maybe Add non-fatal compiler directive}
halt;
end; {Error}
{||||||||||||||||||||||||||||||||||||||||||}
{ }
{ B r o w s e O B J M E T H O D S }
{ }
{||||||||||||||||||||||||||||||||||||||||||}
constructor BrowseOBJ.Init;
{}
begin
new(vWin,Init);
vWin^.SetScrollable(true,true);
vTopPick := 1;
vTotPicks := 1;
vListAssigned := false;
vListVisible := false;
vStartCol := 1;
vEndCol := 80;
vActivePick := 1;
vRows := 0;
end; {BrowseOBJ.Init}

function BrowseOBJ.Win:StretchWinPtr;
{}
begin
Win := vWin;
end; {BrowseOBJ.Win}

procedure BrowseOBJ.SetTopPick(TopPick: longint);
{}
begin
vTopPick := TopPick;
end; {BrowseOBJ.SetTopElement}

procedure BrowseOBJ.SetStartCol(Column: longint);
{}
begin
vStartCol := Column;
end; {BrowseOBJ.SetStartCol}

procedure BrowseOBJ.SetEndCol(Column: longint);
{}
begin
if (Column > vStartCol) or (Column = 0) then
vEndCol := Column
else
vEndCol := vStartCol;
end; {BrowseOBJ.SetEndCol}

function BrowseOBJ.GetString(Pick, Start,Finish: longint):string;
{abstract}
begin end;

procedure BrowseOBJ.DisplayPick(Pick:integer);
{}
var
PickStr: string;
begin
if pred(vTopPick + Pick) <= vTotPicks then
PickStr := GetString(pred(vTopPick + Pick),vStartCol,pred(vStartCol)+vRealColWidth)
else
PickStr := '';
PickStr := padleft(PickStr,vRealColWidth,' ');
Screen.WritePlain(1,Pick,PickStr);
end; {BrowseOBJ.DisplayPick}

procedure BrowseOBJ.DisplayAllPicks;
{}
var I : integer;
begin
for I := 1 to vRows do
DisplayPick(I);
end; {BrowseOBJ.DisplayAllPicks}

procedure BrowseOBJ.ScrollUp;
{}
begin
if vTopPick > 1 then
begin
dec(vTopPick);
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollUp}

procedure BrowseOBJ.ScrollDown;
{}
begin
if vTopPick < vTotPicks then
begin
inc(vTopPick);
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollDown}

procedure BrowseOBJ.SlideLeft;
{}
begin
if vStartCol > 1 then
begin
dec(vStartCol);
DisplayAllPicks;
end;
end; {BrowseOBJ.SlideLeft}

procedure BrowseOBJ.SlideRight;
{}
begin
if (vEndCol = 0) or (vStartCol < vEndCol) then
begin
inc(vStartCol);
DisplayAllPicks;
end;
end; {BrowseOBJ.SlideRight}

procedure BrowseOBJ.ScrollPgUp;
{}
begin
if vTopPick > 1 then
begin
dec(vTopPick,vRows);
if vTopPick < 1 then
vTopPick := 1;
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollPgUp}

procedure BrowseOBJ.ScrollPgDn;
{}
begin
if pred(vTopPick + vRows) < vTotPicks then
begin
inc(vTopPick,vRows);
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollPgDn}

procedure BrowseOBJ.ScrollFarRight;
{}
var EndCol: longint;
begin
if (vEndCol = 0) then
EndCol := 255
else
EndCol := vEndCol;
if (vStartCol < EndCol - pred(vRealColWidth)) then
begin
vStartCol := EndCol - pred(vRealColWidth);
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollFarRight}

procedure BrowseOBJ.ScrollFarLeft;
{}
begin
if vStartCol > 1 then
begin
vStartCol := 1;
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollFarLeft}

procedure BrowseOBJ.ScrollLast;
{}
begin
if pred(vTopPick) + vRows <> vTotPicks then
begin
vTopPick := succ(vTotPicks) - vRows;
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollLast}

procedure BrowseOBJ.ScrollFirst;
{}
begin
if vTopPick <> 1 then
begin
vTopPick := 1;
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollFirst}

procedure BrowseOBJ.ScrollJumpH(X,Y:byte);
{}
var NewStart: longint;
begin
if X = 1 then
NewStart := 1
else if X=Y then
NewStart := vEndCol
else
NewStart := (X * vEndCol) div Y;
if NewStart <> vStartCol then
begin
vStartCol := NewStart;
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollJumpH}

procedure BrowseOBJ.ScrollJumpV(X,Y:byte);
{}
var NewTop: longint;
begin
if X = 1 then
NewTop := 1
else if X=Y then
NewTop := vTotPicks
else
NewTop := (X * vTotPicks) div Y;
if NewTop <> vTopPick then
begin
vTopPick := NewTop;
DisplayAllPicks;
end;
end; {BrowseOBJ.ScrollJumpV}

procedure BrowseOBJ.Go;
{}
var
Finished: boolean;
Mvisible: boolean;
K: word;
X,Y :byte;
CX,CY,CT,CB:byte;
begin
Mvisible := Mouse.Visible;
if Monitor^.ColorOn then
with Screen do
begin
CursSave;
CX := WhereX;
CY := WhereY;
CT := CursTop;
CB := CursBot;
CursOff;
end;
Show;
Finished := false;
repeat
vWin^.DrawHorizBar(vStartCol,vEndCol);
vWin^.DrawVertBar(vTopPick,vTotPicks);
K := Key.GetKey;
X := Key.LastX;
Y := Key.LastY;
vWin^.Winkey(K,X,Y);
if (K = LookTOT^.ListEndKey) or (K = LookTOT^.ListEscKey) then
Finished := true
else
case K of
600: Finished := true; {window close}
602: begin
ResetDimensions;
DisplayAllPicks; {window stretched}
end;
610,328: ScrollUp;
611,336: ScrollDown;
612,331: SlideLeft;
613,333: SlideRight;
337: ScrollPgDn;
329: ScrollPgUp;
335: ScrollFarRight;
327: ScrollFarLeft;
388: ScrollFirst;
374: ScrollLast;
614: ScrollJumpV(X,Y);
615: ScrollJumpH(X,Y);
end; {case}
until Finished;
vLastKey := K;
if Mvisible then
Mouse.Show
else
Mouse.Hide;
if Monitor^.ColorOn then
with Screen do
begin
GotoXY(CX,CY);
CursSize(CT,CB);
end;
end; {BrowseOBJ.Go}

procedure BrowseOBJ.Remove;
{}
begin
vWin^.Remove;
end; {BrowseOBJ.Remove}

function BrowseOBJ.LastKey:word;
{}
begin
LastKey := vLastKey;
end; {BrowseOBJ.LastKey}

procedure BrowseOBJ.ReSetDimensions;
{}
var S: byte;
begin
with vWin^ do
begin
S := GetStyle;
case S of
0: vRows := succ(vBorder.Y2 - vBorder.Y1);
6: vRows := vBorder.Y2 - vBorder.Y1 - 3;
else vRows := pred(vBorder.Y2 - vBorder.Y1)
end; {case}
if S in[0,6] then
vRealColWidth := succ(vBorder.X2 - vBorder.X1)
else
vRealColWidth := pred(vBorder.X2 - vBorder.X1);
end; {with}
end; {Browse.ResetDimensions}

procedure BrowseOBJ.Show;
{}
begin
if vListAssigned = false then
Error(1)
else
begin
if not vListVisible then
begin
vWin^.Draw;
ResetDimensions;
DisplayAllPicks;
vListVisible := true
end;
end;
end; {BrowseOBJ.Show}

destructor BrowseOBJ.Done;
{}
begin
dispose(vWin,Done);
end; {BrowseOBJ.Done}
{|||||||||||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ B r o w s e A r r a y O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||||||||||}
constructor BrowseArrayOBJ.Init;
{}
begin
BrowseObj.Init;
end; {BrowseArrayOBJ.Init}

procedure BrowseArrayOBJ.AssignList(var StrArray; Total:Longint; StrLength:byte);
{}
var
L : Longint;
Dummy: byte;
Result : integer;
begin
vArrayPtr := @StrArray;
vStrLength := StrLength;
vTotPicks := Total;
vListAssigned := true;
vEndCol := StrLength;
end; {BrowseArrayOBJ.AssignList}

function BrowseArrayOBJ.GetString(Pick, Start,Finish: longint):string;
{}
var
W : word;
TempStr : String;
ArrayOffset: word;
begin
{move array string to Temp}
W := pred(Pick) * succ(vStrLength);
ArrayOffset := Ofs(vArrayPtr^) + W;
Move(Mem[Seg(vArrayPtr^):ArrayOffset],TempStr,1);
Move(Mem[Seg(vArrayPtr^):succ(ArrayOffset)],TempStr[1],ord(TempStr[0]));
if Start < 0 then Start := 0;
if Finish < 0 then Finish := 0;
{validate Start and Finish Parameters}
if ((Finish = 0) and (Start = 0))
or (Start > Finish) then {get full string}
begin
Start := 1;
Finish := 255;
end
else if Finish - Start > 254 then {too long to fit in string}
Finish := Start + 254;
if Finish > vStrLength then
Finish := vStrLength;
if (Start > vStrLength) then
GetString := ''
else
begin
GetString := copy(TempStr,Start,succ(Finish - Start));
end;
end; {BrowseArrayOBJ.GetString}

destructor BrowseArrayOBJ.Done;
{}
begin
BrowseObj.Done;
end; {BrowseArrayOBJ.Done}
{|||||||||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ B r o w s e L i n k O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||||||||}
constructor BrowseLinkOBJ.Init;
{}
begin
BrowseObj.Init;
vLinkList := nil;
end; {BrowseLinkOBJ.Init}

procedure BrowseLinkOBJ.AssignList(var LinkList: DLLOBJ);
{}
begin
vLinkList := @LinkList;
vTotPicks := LinkList.TotalNodes;
vListAssigned := true;
vEndCol := LinkList.GetMaxNodeSize;
end; {BrowseLinkOBJ.AssignList}

function BrowseLinkOBJ.GetString(Pick,Start,Finish:longint): string;
{}
var TempPtr : DLLNodePtr;
begin
TempPtr := vLinkList^.NodePtr(Pick);
if TempPtr <> Nil then
vLinkList^.ShiftActiveNode(TempPtr,Pick);
GetString := vLinkList^.GetStr(TempPtr,Start,Finish);
end; {BrowseLinkOBJ.GetString}

function BrowseLinkOBJ.ListPtr: DLLPtr;
{}
begin
ListPtr := vLinkList;
end; {BrowseLinkOBJ.ListPtr}

destructor BrowseLinkOBJ.Done;
{}
begin
BrowseObj.Done;
end; {BrowseLinkOBJ.Done;}
{|||||||||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ B r o w s e F i l e O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||||||||}
constructor BrowseFileOBJ.Init;
{}
begin
BrowseOBJ.Init;
end; {BrowseFileOBJ.Init}

function BrowseFileOBJ.AssignFile(Filename: string): integer;
{RetCodes:
0 OK
1 File not found
2 Run out of memory
}
var
F : text;
Line : string;
Result: integer;
begin
Assign(F,Filename);
{$I-}
Reset(F);
{$I+}
if IOResult <> 0 then
AssignFile := 1
else
begin
new(vStrList,Init);
Result := 0;
while (eof(F) = false) and (Result = 0) do
begin
Readln(F,Line);
Result := vStrList^.Add(Line);
end;
vWin^.SetTitle(filename);
vListAssigned := true;
vTotPicks := vStrList^.TotalNodes;
vEndCol := vStrList^.GetMaxNodeSize;
if Result = 0 then
AssignFile := 0
else
AssignFile := 1;
end;
end; {BrowseFileOBJ.AssignFile}

function BrowseFileOBJ.ListPtr:StrDLLPtr;
{}
begin
ListPtr := vStrList;
end; {BrowseFileOBJ.ListPtr}

function BrowseFileOBJ.GetString(Pick,Start,Finish:longint): string;
{}
var TempPtr : DLLNodePtr;
begin
TempPtr := vStrList^.NodePtr(Pick);
if TempPtr <> Nil then
vStrList^.ShiftActiveNode(TempPtr,Pick);
GetString := vStrList^.GetStr(TempPtr,Start,Finish);
end; {BrowseFileOBJ.GetString}

destructor BrowseFileOBJ.Done;
{}
begin
BrowseOBJ.Done;
dispose(vStrList,Done);
end; {BrowseFileOBJ.Done}
{||||||||||||||||||||||||||||||||||||||}
{ }
{ L i s t O B J M E T H O D S }
{ }
{||||||||||||||||||||||||||||||||||||||}
constructor ListOBJ.Init;
{}
begin
new(vWin,Init);
vWin^.SetScrollable(true,true);
vTopPick := 1;
vTotPicks := 1;
vActivePick := 1;
vListVisible := false;
vListAssigned := false;
vMsgActive := false;
vCharHook := NoCharHook;
vMsgHook := NoMsgHook;
vAllowToggle := true;
vColWidth := 0;
vHAttr := LookTOT^.MenuHiNorm;
vNAttr := LookTOT^.MenuLoNorm;
vSAttr := LookTOT^.MenuOff;
vWin^.SetColors(0,vNattr,0,0);
vDualColors := false;
end; {ListOBJ.Init}

procedure ListOBJ.SetTopPick(TopPick: longint);
{}
begin
vTopPick := TopPick;
end; {ListOBJ.SetTopElement}

procedure ListOBJ.SetActivePick(ThePick: longint);
{}
begin
vActivePick := ThePick;
end; {ListOBJ.SetTopElement}

procedure ListOBJ.SetTagging(On:boolean);
{}
begin
vAllowToggle := On;
end; {ListOBJ.SetTagging}

procedure ListOBJ.SetDualColors(On:boolean);
{}
begin
vDualColors := On;
end; {ListOBJ.SetDualColors}

procedure ListOBJ.SetColors(HAttr,NAttr,SAttr: byte);
{}
begin
vHAttr := HAttr;
vNAttr := NAttr;
vSAttr := SAttr;
vWin^.SetColors(0,vNattr,0,0);
end; {ListOBJ.SetColors}

procedure ListOBJ.SetColWidth(Wid: byte);
{}
begin
vColWidth := Wid;
end; {ListOBJ.SetColumnWidth}

procedure ListOBJ.SetCharHook(Func:ListCharFunc);
{}
begin
vCharHook := Func;
end; {ListOBJ.SetCharHook}

procedure ListOBJ.SetMsgHook(Func:ListMsgFunc);
{}
begin
vMsgHook := Func;
vMsgActive := true;
end; {ListOBJ.SetMsgHook}

procedure ListOBJ.SetMsgState(On:boolean);
{}
begin
vMsgActive := On;
end; {ListOBJ.SetMsgState}

function ListOBJ.GetHiString:string;
{}
begin
GetHiString := GetString(pred(vTopPick+vActivePick),0,0);
end; {ListOBJ.GetHiString}
function ListOBJ.Win:StretchWinPtr;
{}
begin
Win := vWin;
end; {ListOBJ.Win}

procedure ListOBJ.ResetDimensions;
{adjusts the column and row settings based on the list window coords}
var
ListWidth: byte;
Style: byte;
begin
with vZone do
vWin^.GetSize(X1,Y1,X2,Y2,Style);
if Style = 0 then
fillchar(vMargin,sizeof(vMargin),#0)
else
begin
vMargin.X1 := 1;
vMargin.X2 := 1;
vMargin.Y2 := 1;
if Style = 6 then
vMargin.Y1 := 3
else
vMargin.Y1 := 1;
end;
if vColWidth < 5 then
begin
vRealColWidth := succ(vZone.X2 - vZone.X1) - vMargin.X1 - vMargin.X2;
vCols := 1;
vLastColWidth := vRealColWidth;
end
else
begin
vRealColWidth := vColWidth;
ListWidth := succ(vZone.X2 - vZone.X1) - vMargin.X1 - vMargin.X2;
if vRealColWidth > ListWidth then
vRealColWidth := ListWidth;
vCols := ListWidth div vRealColWidth;
vLastColWidth := ListWidth - vCols * vRealColWidth;
if vLastColWidth = 0 then
vLastColWidth := vRealColWidth
else
Inc(vCols);
end;
vUseLastCol := (vCols = 1) or (vLastColWidth = vRealColWidth);
vRows := succ(vZone.Y2 - vZone.Y1) - vMargin.Y1 - vMargin.Y2;
if vMsgActive then
dec(vRows,2); {make space for message}
end; {ListOBJ.ResetDimensions}

procedure ListOBJ.DisplayPick(Pick:integer; Hi:boolean);
{}
var
X,Y,Att,Pad,Max,L: byte;
W : LongInt;
Partial,
Selected: boolean;
PadLeft,PadRight: string[1];
PickStr : String;
LeftChar,
RightChar,
ToggleOnChar,
ToggleOffChar : char;
begin
if vTotPicks = 0 then
exit;
LeftChar := LookTOT^.ListLeftChar;
RightChar := LookTOT^.ListRightChar;
ToggleOnChar := LookTOT^.ListToggleOnChar;
ToggleOffChar := LookTOT^.ListToggleOffChar;
Partial := (vCols > 1) and (Pick > vRows * Pred(vCols))
and (vLastColWidth <> vRealColWidth);
If pred(vTopPick + Pick) > vTotPicks then
begin
Att := vNAttr;
if not Partial then
PickStr := replicate(vRealColWidth,' ')
else
PickStr := replicate(vLastColWidth,' ');
end
else
begin
Selected := false;
Pad := ord(LeftChar<>#0) + 2*ord(vAllowToggle);
if not Partial then
Pad := Pad + ord(RightChar<>#0);
if vAllowToggle then
Selected := GetStatus(pred(vTopPick+Pick), 0);
if Hi then
Att := vHAttr
else
begin
if vDualColors and GetStatus(pred(vTopPick+Pick),1) then
Att := vSAttr
else
Att := vNAttr;
end;
if (vCols = 1) or (Pick <= vRows * pred(vCols)) then
begin
Max := vRealColWidth;
W := vRealColWidth - pad;
end
else
begin
Max := vLastColWidth;
W := vLastColWidth - pad;
end;
if W < 0 then
PickStr := ''
else
begin
PickStr := GetString(pred(vTopPick + Pick),1,W);
L := length(PickStr);
If L < W then {pad out the name}
PickStr := PickStr + replicate(W-L,' ');
end;
if vAllowToggle then
begin
if Selected then
PickStr := ToggleOnChar+' '+PickStr
else
PickStr := ToggleOffChar+' '+PickStr;
end;
if Hi then
begin
if (LeftChar <> #0) then
PickStr := LeftChar+PickStr;
if (RightChar <> #0) then
PickStr := PickStr+RightChar;
end
else
begin
if (LeftChar = #0) then
Padleft := ''
else
PadLeft := ' ';
if (RightChar = #0) or Partial then
PadRight := ''
else
PadRight := ' ';
PickStr := PadLeft+PickStr+PadRight;
end;
if length(PickStr) > Max then
PickStr := copy(PickStr,1,Max);
end;
if Pick <= vRows then
X := 1
else
X := succ(vRealColWidth*(pred(Pick) div vRows));
if Pick mod vRows = 0 then
Y := vRows
else
Y := (Pick mod vRows);
{now write the pick}
Screen.WriteAT(X,Y,Att,PickStr);
if Hi then
begin
Screen.GotoXY(X,Y);
if vMsgActive then
begin
PickStr := MessageTask(pred(vTopPick+vActivePick));
Screen.WriteAt(1,succ(vZone.Y2 - vMargin.Y2 - vZone.Y1 - vMargin.Y1),
vWin^.GetTitleAttr,
PadCenter(PickStr,succ(vZone.X2 - vZone.X1 - vMargin.X2 - vMargin.X1),' '));
end;
end;
end; {ListOBJ.DisplayPick}

procedure ListOBJ.DisplayAllPicks;
{}

var
I,J:integer;
begin
for I := 1 to vCols do
for J := 1 to vRows do
DisplayPick(pred(I)*vRows + J,(pred(I)*vRows + J) = vActivePick);
end; {ListOBJ.DisplayAllPicks}

procedure ListOBJ.ValidateActivePick;
{}
var I,J : Integer;
begin
if (vUseLastCol) or (vCols = 1) then
I := vCols*vRows
else
I := pred(vCols)*vRows;
if (vActivePick > I) or (vActivePick < 1) then
vActivePick := 1;
end; {ListOBJ.ValidateActivePick}

procedure ListOBJ.RefreshList;
{}
begin
ResetDimensions;
ValidateActivePick;
if vMsgActive then
begin
Screen.HorizLine(1,succ(vZone.X2 - vZone.X1 - vMargin.X2 - vMargin.X1),
vZone.Y2 - vMargin.Y2 - vZone.Y1 - vMargin.Y1,
Win^.GetBorderAttr,
1);
end;
DisplayAllPicks;
end; {ListOBJ.RefreshList}

procedure ListOBJ.ScrollDown;
{}
var LastPick : integer;
begin
if pred(vTopPick + vActivePick) < vTotPicks then {not end of list}
begin
if (vUseLastCol) or (vCols = 1) then
LastPick := vCols*vRows
else
LastPick := pred(vCols)*vRows;
if vActivePick < LastPick then
begin
DisplayPick(vActivePick,false);
inc(vActivePick);
DisplayPick(vActivePick,True);
end
else
begin
inc(vTopPick);
DisplayAllPicks;
end;
end;
end; {ListOBJ.ScrollDown}

procedure ListOBJ.ScrollUp;
{}
begin
if vActivePick = 1 then
begin
if vTopPick > 1 then
begin
dec(vTopPick);
DisplayAllPicks;
end;
end
else
begin
DisplayPick(vActivePick,false);
dec(vActivePick);
DisplayPick(vActivePick,True);
end;
end; {ListOBJ.ScrollUp}

procedure ListObj.JumpEngine(Tot, NewValue: longint);
{}
var I: Integer;
begin
if NewValue < 1 then
NewValue := 1;
if (Tot < (vCols - ord(not vUseLastCol)) * vRows)
and (vTopPick <= NewValue) then {full list on display}
begin
DisplayPick(vActivePick,false);
vActivePick := NewValue - pred(vTopPick);
DisplayPick(vActivePick,True);
end
else
begin
vTopPick := NewValue;
vActivePick := 1;
DisplayAllPicks;
end;
end; {JumpEngine}

procedure ListOBJ.ScrollJumpV(X,Y:byte);
{}
var
NewValue: LongInt;
begin
NewValue := (X * vTotPicks) div Y;
JumpEngine(vTotPicks,NewValue)
end; {ListOBJ.ScrollJumpV}

procedure ListOBJ.ScrollJumpH(X,Y:byte);
{}
var
NewValue: LongInt;
begin
NewValue := (X * vTotPicks) div Y;
JumpEngine(vTotPicks,NewValue)
end; {ListOBJ.ScrollJumpH}

procedure ListOBJ.ScrollLeft;
{}
begin
if (vCols = 1) or ((vCols = 2) and not vUselastCol) then
ScrollUp
else
if vActivePick > vRows then {not in first column}
begin
DisplayPick(vActivePick,false);
vActivePick := vActivePick - vRows;
DisplayPick(vActivePick,True);
end
else if vTopPick > vRows then {leftmost column}
begin
vTopPick := vTopPick - vRows;
DisplayAllPicks;
end
else
begin
vTopPick := 1;
vActivePick := 1;
DisplayAllPicks;
end;
end; {ListOBJ.ScrollLeft}

procedure ListOBJ.ScrollRight;
{}
begin
if (vCols = 1) or ((vCols = 2) and not vUselastCol) then
ScrollDown
else
if (vActivePick < pred(vCols -ord(not vUseLastCol)) * vRows) {not in last column}
or (vTopPick + (vRows*(vCols -ord(not vUseLastCol))) >= vTotPicks) then
begin
DisplayPick(vActivePick,false);
vActivePick := vActivePick + vRows;
if vTopPick + pred(vActivePick) > vTotPicks then
vActivePick := succ(vTotPicks - vTopPick);
DisplayPick(vActivePick,True);
end
else
begin
vTopPick := vTopPick + vRows;
if vTopPick + pred(vActivePick) > vTotPicks then
vActivePick := succ(vTotPicks - vTopPick);
DisplayAllPicks;
end;
end; {ListOBJ.ScrollRight}

procedure ListOBJ.ScrollFarRight;
{}
begin
while (vActivePick < pred(vCols -ord(not vUseLastCol)) * vRows) do
inc(vActivePick,vRows);
while (vTopPick + (vCols -ord(not vUseLastCol)) * vRows < vTotPicks)
and (vTopPick + pred(vActivePick) + vRows <= vTotPicks) do
inc(vTopPick,vRows);
DisplayAllPicks;
end; {ListOBJ.ScrollFarRight}

procedure ListOBJ.ScrollFarLeft;
{}
begin
while vActivePick - vRows > 0 do
dec(vActivePick,vRows);
vTopPick := 1;
DisplayAllPicks;
end; {ListOBJ.ScrollFarLeft}

procedure ListOBJ.ScrollPgDn;
{}
begin
if pred(vTopPick + vRows) < vTotPicks then
begin
vTopPick := vTopPick + vRows;
vActivePick := 1;
DisplayAllPicks;
end;
end; {ListOBJ.ScrollPgDn}

procedure ListOBJ.ScrollPgUp;
{}
begin
if vTopPick > 1 then
begin
vTopPick := vTopPick - vRows;
if vTopPick < 1 then
vTopPick := 1;
DisplayAllPicks;
end;
end; {ListOBJ.ScrollPgUp}

procedure ListOBJ.ScrollLast;
{}
begin
if vTopPick + pred((vCols -ord(not vUseLastCol)) * vRows) >= vTotPicks then {last node on display}
begin
DisplayPick(vActivePick,False);
vActivePick := succ(vTotPicks - vTopPick);
DisplayPick(vActivePick,True);
end
else
begin
vTopPick := vTotPicks;
vActivePick := 1;
DisplayAllPicks;
end;
end; {ListOBJ.ScrollLast}

procedure ListOBJ.ScrollFirst;
{}
begin
vTopPick := 1;
vActivePick := 1;
DisplayAllPicks;
end; {ListOBJ.ScrollFirst}

procedure ListOBJ.ToggleSelect;
{}
begin
SetStatus(pred(vTopPick+vActivePick), 0,not GetStatus(pred(vTopPick+vActivePick),0));
if pred(vTopPick + vActivePick) < vTotPicks then
ScrollDown
else
DisplayPick(vActivePick,True);
end; {of ListOBJ.ToggleSelect}

function ListOBJ.TargetPick(X,Y:byte): Integer;
{return the pick number of the pick pointed to by
the coordinates X,Y. If no pick is at those coordinates, a
0 is returned}
begin
if (X >= vZone.X1 + vMargin.X1)
and (X <= vZone.X2 - vMargin.X2)
and (Y >= vZone.Y1 + vMargin.Y1)
and (Y <= vZone.Y1 + vMargin.Y1 + pred(vRows))
then
begin
X := succ(X - vZone.X1 - vMargin.X1);
Y := succ(Y - vZone.Y1 - vMargin.Y1);
if X mod vRealColWidth = 0 then
X := X div vRealColWidth
else
X := succ(X div vRealColWidth);
if (X < vCols)
or ((X = vCols) and vUseLastCol) then
begin
if vTopPick + pred(pred(X)*vRows + Y) <= vTotPicks then
begin
TargetPick := pred(X)*vRows + Y;
exit;
end;
end;
end;
TargetPick := 0;
end; {ListOBJ.TargetPick}

procedure ListOBJ.MouseChoose(KeyX,KeyY:byte);
{}
var
HitPick : integer;
begin
HitPick := TargetPick(KeyX,KeyY);
if HitPick <> 0 then
begin
DisplayPick(vActivePick,false);
vActivePick := HitPick;
SetStatus(pred(vTopPick+vActivePick),0,not GetStatus(pred(vTopPick+vActivePick),0));
DisplayPick(vActivePick,True);
end;
end; {ListOBJ.MouseChoose}

procedure ListOBJ.Show;
{}
begin
if vListAssigned = false then
Error(1)
else
begin
if not vListVisible then
begin
vWin^.Draw;
RefreshList;
vListVisible := true
end;
end;
end; {ListOBJ.Show}

procedure ListOBJ.Go;
{}
var
Finished: boolean;
Mvisible: boolean;
Kdouble: boolean;
K: word;
X,Y :byte;
CursX,CursY: byte;
Msg : string;
CX,CY,CT,CB:byte;

procedure ProcessAction(Act: tListAction);
{}
begin
case Act of
Finish: begin
K := 0;
Finished := true;
end;
Refresh: begin
K := 0;
RefreshList;
end;
None:; {nothing!}
end; {case}
end; {ProcessAction}

begin
if Monitor^.ColorOn then
with Screen do
begin
CursSave;
CX := WhereX;
CY := WhereY;
CT := CursTop;
CB := CursBot;
CursOff;
end;
Mvisible := Mouse.Visible;
Show;
kDouble := Key.GetDouble;
if not kDouble then
Key.SetDouble(true);
Mouse.Show;
Finished := false;
repeat
CursX := Screen.WhereX;
CursY := Screen.WhereY;
vWin^.DrawHorizBar(pred(vTopPick+vActivePick),vTotPicks);
vWin^.DrawVertBar(pred(vTopPick+vActivePick),vTotPicks);
Screen.GotoXY(CursX,CursY);
K := Key.GetKey;
X := Key.LastX;
Y := Key.LastY;
vWin^.Winkey(K,X,Y);
ProcessAction(CharTask(K,X,Y,pred(vTopPick+vActivePick)));
if (K = LookTOT^.ListEndKey) or (K = LookTOT^.ListEscKey) then
Finished := true
else if (K = LookTOT^.ListToggleKey) and vAllowToggle then
ToggleSelect
else if (K = LookTOT^.ListTagKey) and vAllowToggle then
TagAll(true)
else if (K = LookTOT^.ListUnTagKey) and vAllowToggle then
TagAll(false)
else
case K of
13: if vAllowToggle = false then
Finished := true
else
ToggleSelect;
600: Finished := true; {window close}
601: ResetDimensions;
602: RefreshList;
610,328: ScrollUp;
611,336: ScrollDown;
612,331: ScrollLeft;
613,333: ScrollRight;
513: MouseChoose(X,Y); {leftMouse}
523: if TargetPick(X,Y) <> 0 then
begin
MouseChoose(X,Y);
Finished := True;
end;
337: if (vCols = 1) or ((vCols = 2) and not vUselastCol) then {PgDn}
ScrollPgDn
else
ScrollRight;
329: if (vCols = 1) or ((vCols = 2) and not vUselastCol) then {PgUp}
ScrollPgUp
else
ScrollLeft;

335: ScrollFarRight;
327: ScrollFarLeft;
388: ScrollFirst;
374: ScrollLast;
614: begin {vertical scroll bar}
if X = 1 then
ScrollFirst
else if X = Y then
ScrollLast
else
ScrollJumpV(X,Y); {vertical scroll bar}
end;
615: begin {horizontal scroll bar}
if X = 1 then
ScrollFirst
else if X = Y then
ScrollLast
else
ScrollJumpH(X,Y); {vertical scroll bar}
end;
end; {case}
until Finished;
vLastKey := K;
if Mvisible then
Mouse.Show
else
Mouse.Hide;
if Monitor^.ColorOn then
with Screen do
begin
GotoXY(CX,CY);
CursSize(CT,CB);
end;
Key.SetDouble(KDouble);
end; {ListOBJ.Go}

function ListOBJ.LastKey:word;
{}
begin
LastKey := vLastKey;
end; {ListOBJ.LastKey}

procedure ListOBJ.Remove;
{}
begin
vWin^.Remove;
end; {ListOBJ.Remove}

function ListOBJ.CharTask(var K:word; var X,Y: byte;HiPick:longint): tListAction;
{}
begin
CharTask := vCharHook(K,X,Y,HiPick);
end; {ListOBJ.CharTask}

function ListOBJ.MessageTask(HiPick:longint):string;
{}
begin
MessageTask := vMsgHook(HiPick);
end; {ListOBJ.MessageTask}

function ListOBJ.GetString(Pick, Start,Finish: longint):string;
{abstract}
begin end;

function ListOBJ.GetStatus(Pick:longint; BitPos:byte): boolean;
{abstract}
begin end;

procedure ListObj.SetStatus(Pick:longint; BitPos:byte;On:boolean);
{abstract}
begin end;

procedure ListOBJ.TagAll(On:boolean);
{}
begin end;

destructor ListOBJ.Done;
{}
begin
dispose(vWin,Done);
end; {ListOBJ.Done}
{|||||||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ L i s t A r r a y O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||||||}
constructor ListArrayOBJ.Init;
{}
begin
ListObj.Init;
vLinkList := Nil;
end; {ListArrayOBJ.Init}

procedure ListArrayOBJ.AssignList(var StrArray; Total:Longint; StrLength:byte; Selectable: boolean);
{}
var
L : Longint;
Dummy: byte;
Result : integer;
begin
vArrayPtr := @StrArray;
vStrLength := StrLength;
vTotPicks := Total;
vListAssigned := true;
vAllowToggle := Selectable;
if vAllowToggle then {assign a linked list to record selections}
begin
if MemAvail < SizeOf(vLinkList^) then
begin
vAllowToggle := False;
exit;
end;
New(vLinkList,Init);
with vLinkList^ do
begin
Dummy := 0;
For L := 1 to Total do
begin
Result := Add(Dummy,0);
if Result <> 0 then
begin
Dispose(vLinkList,Done);
vAllowToggle := false;
end;
end;
end;
end;
end; {ListArrayOBJ.AssignList}

procedure ListArrayOBJ.SetTagging(On:boolean);
{}
begin
if On and (vLinkList <> Nil) then
vAllowToggle := true
else
vAllowToggle := false;
end; {ListOBJ.SetTagging}

function ListArrayOBJ.GetString(Pick, Start,Finish: longint):string;
{}
var
W : longint;
TempStr : String;
ArrayOffset: word;
begin
{move array string to Temp}
W := pred(Pick) * succ(vStrLength);
ArrayOffset := Ofs(vArrayPtr^) + W;
Move(Mem[Seg(vArrayPtr^):ArrayOffset],TempStr,1);
Move(Mem[Seg(vArrayPtr^):succ(ArrayOffset)],TempStr[1],ord(TempStr[0]));
if Start < 0 then Start := 0;
if Finish < 0 then Finish := 0;
{validate Start and Finish Parameters}
if ((Finish = 0) and (Start = 0))
or (Start > Finish) then {get full string}
begin
Start := 1;
Finish := 255;
end
else if Finish - Start > 254 then {too long to fit in string}
Finish := Start + 254;
if Finish > vStrLength then
Finish := vStrLength;
if (Start > vStrLength) then
GetString := ''
else
begin
GetString := copy(TempStr,Start,succ(Finish - Start));
end;
end; {ListArrayOBJ.GetString}

function ListArrayOBJ.GetStatus(Pick:longint; BitPos:byte): boolean;
{}
begin
GetStatus := vLinkList^.NodePtr(Pick)^.GetStatus(BitPos);
end; {ListArrayOBJ.GetStatus}

procedure ListArrayObj.SetStatus(Pick:longint; BitPos:byte;On:boolean);
{}
begin
vLinkList^.NodePtr(Pick)^.SetStatus(BitPos,On);
end; {ListArrayObj.SetStatus}

procedure ListArrayOBJ.TagAll(On:boolean);
{}
var NodeP : DLLNodePtr;
begin
NodeP := vLinkList^.StartNodePtr;
while NodeP <> Nil do
begin
NodeP^.SetStatus(0,On);
NodeP := NodeP^.NextPtr;
end;
DisplayAllPicks;
end; {ListOBJ.TagAll}

destructor ListArrayOBJ.Done;
{}
begin
if vLinkList <> nil then
Dispose(vLinkList,Done);
ListObj.Done;
end; {ListArrayOBJ.Done}
{|||||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ L i s t L i n k O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||||}
constructor ListLinkOBJ.Init;
{}
begin
ListObj.Init;
vLinkList := nil;
end; {ListLinkOBJ.Init}

procedure ListLinkOBJ.AssignList(var LinkList: DLLOBJ);
{}
begin
vLinkList := @LinkList;
vTotPicks := LinkList.TotalNodes;
vListAssigned := true;
end; {ListLinkOBJ.AssignList}

function ListLinkOBJ.ListPtr: DLLPtr;
{}
begin
ListPtr := vLinkList;
end; {ListLinkOBJ.ListPtr}

function ListLinkOBJ.GetString(Pick, Start,Finish: longint):string;
{}
var TempPtr : DLLNodePtr;
begin
TempPtr := vLinkList^.NodePtr(Pick);
if TempPtr <> Nil then
vLinkList^.ShiftActiveNode(TempPtr,Pick);
GetString := vLinkList^.GetStr(TempPtr,Start,Finish);
end; {ListLinkOBJ.GetString}

function ListLinkOBJ.GetStatus(Pick:longint; BitPos:byte): boolean;
{}
begin
GetStatus := vLinkList^.NodePtr(Pick)^.GetStatus(BitPos);
end; {ListLinkOBJ.GetStatus}

procedure ListLinkObj.SetStatus(Pick:longint; BitPos:byte;On:boolean);
{}
begin
vLinkList^.NodePtr(Pick)^.SetStatus(BitPos,On);
end; {ListLinkObj.SetStatus}

procedure ListLinkOBJ.TagAll(On:boolean);
{}
var NodeP : DLLNodePtr;
begin
NodeP := vLinkList^.StartNodePtr;
while NodeP <> Nil do
begin
NodeP^.SetStatus(0,On);
NodeP := NodeP^.NextPtr;
end;
DisplayAllPicks;
end; {ListOBJ.TagAll}

destructor ListLinkOBJ.Done;
{}
begin
ListObj.Done;
end; {ListLinkOBJ.Done}
{|||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ L i s t D i r O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||}
constructor ListDirOBJ.Init;
{}
begin
ListObj.Init;
new(vFileList,Init);
vMsgActive := true;
vDualColors := true;
vColWidth := 15;
vWin^.SetSize(10,5,71,20,1);
end; {ListDirOBJ.Init}

procedure ListDirOBJ.ReadFiles(FileMasks:string; FileAttrib: word);
{}
begin
if FileMasks = '' then
FileMasks := '*.*';
vFileList^.SetFileDetails(FileMasks,FileAttrib);
if (pos(':',Filemasks)=0) and (pos('\',Filemasks)=0) then
begin
GetDir(0,vActiveDir);
if not (vActiveDir[length(vActiveDir)] in [':','\']) then
vActiveDir := vActiveDir + '\';
Filemasks := vActiveDir+Filemasks;
end;
Win^.SetTitle(FileMasks);
vFileList^.FillList;
vTotPicks := vFileList^.TotalNodes;
vListAssigned := true;
end; {ListDirOBJ.ReadFiles}

function ListDirOBJ.GetString(Pick, Start,Finish: longint):string;
{}
var TempPtr : DLLNodePtr;
begin
TempPtr := vFileList^.NodePtr(Pick);
if TempPtr <> Nil then
vFileList^.ShiftActiveNode(TempPtr,Pick);
GetString := vFileList^.GetStr(TempPtr,Start,Finish);
end; {ListDirOBJ.GetString}

function ListDirOBJ.CharTask(var K:word; var X,Y: byte;HiPick:longint): tListAction;
{}
var
FileInfo: tFileInfo;
HitPick : integer;
begin
CharTask := none;
if (K = 13) or (K = 513) then
begin
if K = 513 then
begin
HitPick := TargetPick(X,Y);
if HitPick <> 0 then
HiPick := pred(vTopPick+HitPick)
else
exit;
end;
vFileList^.GetFileRecord(FileInfo,HiPick);
if SubDirectory(FileInfo.Attr) then
begin
{$I-}
ChDir(FileInfo.FileName);
{$I+}
if IOResult = 0 then
begin
vFileList^.FillList;
vTotPicks := vFileList^.TotalNodes;
vTopPick := 1;
vActivePick := 1;
CharTask := Refresh;
GetDir(0,vActiveDir);
if not (vActiveDir[length(vActiveDir)] in [':','\']) then
vActiveDir := vActiveDir + '\';
Win^.SetTitle(vActiveDir+vFileList^.GetFileMask);
Win^.Refresh;
end;
end
else if (K= 13) or ((K=513) and (vAllowToggle = false)) then
CharTask := Finish;
end;
end; {ListDirOBJ.CharTask}

function ListDirOBJ.GetHiString:string;
{}
begin
GetHiString := vActiveDir + GetString(pred(vTopPick+vActivePick),0,0);
end; {ListDirOBJ.GetHiString}

function ListDirOBJ.MessageTask(Hi:longint): string;
{}
var TempPtr : DLLNodePtr;
begin
TempPtr := vFileList^.NodePtr(Hi);
if TempPtr <> Nil then
vFileList^.ShiftActiveNode(TempPtr,Hi);
MessageTask := vFileList^.GetLongStr(TempPtr);
end; {ListDirOBJ.MessageTask}

function ListDirOBJ.GetStatus(Pick:longint; BitPos:byte): boolean;
{}
begin
GetStatus := vFileList^.NodePtr(Pick)^.GetStatus(BitPos);
end; {ListDirOBJ.GetStatus}

procedure ListDirObj.SetStatus(Pick:longint; BitPos:byte;On:boolean);
{}
begin
vFileList^.NodePtr(Pick)^.SetStatus(BitPos,On);
end; {ListDirObj.SetStatus}

procedure ListDirOBJ.TagAll(On:boolean);
{}
var NodeP : DLLNodePtr;
begin
NodeP := vFileList^.StartNodePtr;
while NodeP <> Nil do
begin
NodeP^.SetStatus(0,On);
NodeP := NodeP^.NextPtr;
end;
DisplayAllPicks;
end; {ListOBJ.TagAll}

function ListDirOBJ.FileList: FileDLLPtr;
{}
begin
FileList := vFileList;
end; {ListDirOBJ.FileList}

procedure ListDirOBJ.Go;
{}
var
D: string;
begin
GetDir(0,D);
ListOBJ.Go;
{$I-}
ChDir(D);
{$I+}
if IOResult <> 0 then
{whogivesashit};
end; {ListDirOBJ.Go}

destructor ListDirOBJ.Done;
{}
begin
ListObj.Done;
dispose(vFileList,Done);
end; {ListDirOBJ.Done}
{|||||||||||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ L i s t D i r S o r t O B J M E T H O D S }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||||||||||}
constructor ListDirSortOBJ.Init;
{}
begin
ListDirObj.Init;
end; {ListDirSortOBJ.Init}

function ListDirSortOBJ.PromptAndSort: boolean;

{}
var
Manager: WinFormOBJ;
Control: ControlKeysIOOBJ;
OK,Cancel: Strip3DIOOBJ;
SField,SOrder: RadioIOOBJ;
Result: tAction;
SortField: byte;
SortOrder: boolean;
begin
Control.Init; {Tab, STab, Enter, Esc}
OK.Init(23,5,' ~O~K ',Finished);
OK.SetHotKey(79);{O}
Cancel.Init(23,8,' ~C~ancel ',Escaped);
Cancel.SetHotKey(67); {C}
with SField do
begin
Init(3,2,18,6,'Sort on:');
AddItem('Nat~u~ral DOS',ord('U'),vFileList^.vSortID = 0);
AddItem('~N~ame',ord('N'),vFileList^.vSortID = 1);
AddItem('~E~xt', ord('E'),vFileList^.vSortID = 2);
AddItem('~S~ize',ord('S'),vFileList^.vSortID = 3);
AddItem('~T~ime',ord('T'),vFileList^.vSortID = 4);
SetID(1);
end;
with SOrder do
begin
Init(3,9,18,3,'Sort Order:');
AddItem('~A~scending',ord('A'),vFileList^.vSortAscending);
AddItem('~D~escending',ord('D'),not vFileList^.vSortAscending);
end;
with Manager do
begin
Init;
AddItem(Control);
AddItem(SField);
AddItem(SOrder);
AddItem(OK);
AddItem(Cancel);
SetActiveItem(1);
Win^.SetSize(25,2,58,15,1);
Win^.SetTitle('Directory Sort Options');
Draw;
Result := Go;
SortField := pred(Sfield.GetValue);
SortOrder := (SOrder.GetValue = 1);
Control.Done;
OK.Done;
Cancel.Done;
SField.Done;
SOrder.Done;
Done;
end;
if Result = Finished then
begin
vFileList^.Sort(SortField,SortOrder);
vTopPick := 1;
vActivePick := 1;
PromptAndSort := true;
end
else
PromptAndSort := false;
end; {ListDirSortOBJ.PromptAndSort}

function ListDirSortOBJ.CharTask(var K:word; var X,Y: byte;HiPick:longint): tListAction;
{}
var
FileInfo: tFileInfo;
D : string;
MP: longint;
begin
CharTask := none;
if (K = 83) or (K = 115) or (K = 514) then {'S','s',rightbutton}
begin
if PromptAndSort then
CharTask := Refresh
else
CharTask := none;
end
else
CharTask := ListDirOBJ.CharTask(K,X,Y,HiPick);
end; {ListDirSortOBJ.CharTask}

destructor ListDirSortOBJ.Done;
{}
begin
ListDirObj.Done;
end; {ListDirSortOBJ.Done}
{|||||||||||||||||||||||||||||||||||||||||||||||}
{ }
{ U N I T I N I T I A L I Z A T I O N }
{ }
{|||||||||||||||||||||||||||||||||||||||||||||||}

procedure ListInit;
{initilizes objects and global variables}
begin
end;

{end of unit - add initialization routines below}
{$IFNDEF OVERLAY}
begin
ListInit;
{$ENDIF}
end.





  3 Responses to “Category : Pascal Source Code
Archive   : TJOCKOT1.ZIP
Filename : TOTLIST.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/