home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
m
/
mltpik.zip
/
MULTPICK.PAS
next >
Wrap
Pascal/Delphi Source File
|
1992-10-21
|
5KB
|
156 lines
{$R-,S-,I-,V-,B-,F+,O+,A-}
{Conditional defines that may affect this unit}
{$I OPDEFINE.INC}
{
Written by TurboPower Software, 4/8/90.
Requires Object Professional 1.01 or later to compile and run.
}
unit MultPick;
{-PickList extension that supports multiple lines per pick item}
interface
uses
OpInline,
OpString,
OpConst, {!!.20}
OpRoot,
OpCrt,
{$IFDEF UseMouse}
OpMouse,
{$ENDIF}
OpCmd,
OpFrame,
OpWindow,
OpPick;
type
MultiLinePickListPtr = ^MultiLinePickList;
mlStringProc = procedure (RecNum : Word;
FieldNum : Word;
RecIsCurrent : Boolean;
var IString : String;
MLPickPtr : MultiLinePickListPtr);
MultiLinePickList =
object(PickList)
mlFields : Word; {Number of fields per record}
mlString : mlStringProc; {User string procedure}
constructor InitDeluxe(X1, Y1, X2, Y2 : Byte; var Colors : ColorSet;
Options : LongInt; ItemWidth : Byte;
NumRecords : Word; NumFields : Word;
StringProc : mlStringProc; PickOptions : Word);
{-Initialize a pick window with custom window and pick options}
function Item2Record(Item : Word) : Word;
{-Return the record number corresponding to given Item}
procedure ItemString(Item : Word; Mode : pkMode; var IType : pkItemType;
var IString : String); virtual;
{-Supplies each item string when the list is displayed or searched}
{... for internal use ...}
procedure pkUpdatePick(pFirst, pChoice : Word;
pRow, pCol : Byte); virtual;
end;
{=======================================================================}
implementation
constructor MultiLinePickList.InitDeluxe(X1, Y1, X2, Y2 : Byte;
var Colors : ColorSet;
Options : LongInt;
ItemWidth : Byte;
NumRecords : Word;
NumFields : Word;
StringProc : mlStringProc;
PickOptions : Word);
{-Initialize a pick window with custom window and pick options}
const
Bord : array[Boolean] of Byte = (0, 1);
var
Cols : Byte;
Rows : Byte;
begin
mlFields := NumFields;
mlString := StringProc;
{Assure rows come out even}
if (Y2-Y1+1) mod NumFields <> 0 then begin
Y2 := Y1-1+NumFields*(((Y2-Y1+1) div NumFields)+1);
while Y2+Bord[LongFlagIsSet(Options, wBordered)] > ScreenHeight do
dec(Y2, NumFields);
if Y2 < Y1 then begin
InitStatus := epFatal+ecWinCoordsBad;
Fail;
end;
end;
if not InitAbstractDeluxe(X1, Y1, X2, Y2, Colors, Options,
ItemWidth, NumRecords*NumFields,
PickSnaking, SingleChoice, PickOptions) then
Fail;
end;
function MultiLinePickList.Item2Record(Item : Word) : Word;
{-Return the record number corresponding to given Item}
begin
Item2Record := ((Item-1) div mlFields)+1;
end;
procedure MultiLinePickList.ItemString(Item : Word; Mode : pkMode;
var IType : pkItemType;
var IString : String);
{-Supplies each item string when the list is displayed or searched}
var
RecNumZero : Word; {Zero-based record number}
FieldNum : Word;
RecIsCurrent : Boolean;
Attr : Byte;
begin
{Compute the record and field number}
RecNumZero := (Item-1) div mlFields;
FieldNum := Item-mlFields*RecNumZero;
{Only the first field of each record is unprotected}
if FieldNum <> 1 then
IType := pkProtected;
{Get out quick if we just need the item type}
if Mode = pkGetType then
Exit;
RecIsCurrent := (RecNumZero = (GetLastChoice-1) div mlFields);
{Get the string}
mlString(RecNumZero+1, FieldNum, RecIsCurrent, IString, @Self);
{Fix up the protected attributes}
if FieldNum <> 1 then begin
if RecIsCurrent then
Attr := pkColorPtr^[pkNormal, True][0]
else
Attr := pkColorPtr^[pkNormal, False][0];
pkColorPtr^[pkProtected, False][0] := Attr;
end;
end;
procedure MultiLinePickList.pkUpdatePick(pFirst, pChoice : Word;
pRow, pCol : Byte);
begin
{Draw the whole page every time so protected items are correctly updated}
pkDrawPage(True);
if pkFirst <> pFirst then
if pkMoreRec.HdrNum <> 255 then
pkUpdateMoreRec(pkMoreRec, (pkFirst > 1),
(pkFirst < pkMaxFirst),
(pkItemRows > pkHeight));
{$IFDEF UseScrollBars}
pkUpdScrBar(@Self);
{$ENDIF}
end;
end.