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 >
Pascal/Delphi Source File  |  1992-10-21  |  5KB  |  156 lines
  1. {$R-,S-,I-,V-,B-,F+,O+,A-}
  2.  
  3. {Conditional defines that may affect this unit}
  4. {$I OPDEFINE.INC}
  5.  
  6. {
  7.  Written by TurboPower Software, 4/8/90.
  8.  Requires Object Professional 1.01 or later to compile and run.
  9. }
  10.  
  11. unit MultPick;
  12.   {-PickList extension that supports multiple lines per pick item}
  13.  
  14. interface
  15.  
  16. uses
  17.   OpInline,
  18.   OpString,
  19.   OpConst, {!!.20}
  20.   OpRoot,
  21.   OpCrt,
  22.   {$IFDEF UseMouse}
  23.   OpMouse,
  24.   {$ENDIF}
  25.   OpCmd,
  26.   OpFrame,
  27.   OpWindow,
  28.   OpPick;
  29.  
  30. type
  31.   MultiLinePickListPtr = ^MultiLinePickList;
  32.  
  33.   mlStringProc = procedure (RecNum : Word;
  34.                             FieldNum : Word;
  35.                             RecIsCurrent : Boolean;
  36.                             var IString : String;
  37.                             MLPickPtr : MultiLinePickListPtr);
  38.  
  39.   MultiLinePickList =
  40.     object(PickList)
  41.       mlFields : Word;         {Number of fields per record}
  42.       mlString : mlStringProc; {User string procedure}
  43.       constructor InitDeluxe(X1, Y1, X2, Y2 : Byte; var Colors : ColorSet;
  44.                              Options : LongInt; ItemWidth : Byte;
  45.                              NumRecords : Word; NumFields : Word;
  46.                              StringProc : mlStringProc; PickOptions : Word);
  47.         {-Initialize a pick window with custom window and pick options}
  48.       function Item2Record(Item : Word) : Word;
  49.         {-Return the record number corresponding to given Item}
  50.       procedure ItemString(Item : Word; Mode : pkMode; var IType : pkItemType;
  51.                            var IString : String); virtual;
  52.         {-Supplies each item string when the list is displayed or searched}
  53.       {... for internal use ...}
  54.       procedure pkUpdatePick(pFirst, pChoice : Word;
  55.                              pRow, pCol : Byte); virtual;
  56.     end;
  57.  
  58.   {=======================================================================}
  59.  
  60. implementation
  61.  
  62.   constructor MultiLinePickList.InitDeluxe(X1, Y1, X2, Y2 : Byte;
  63.                                            var Colors : ColorSet;
  64.                                            Options : LongInt;
  65.                                            ItemWidth : Byte;
  66.                                            NumRecords : Word;
  67.                                            NumFields : Word;
  68.                                            StringProc : mlStringProc;
  69.                                            PickOptions : Word);
  70.     {-Initialize a pick window with custom window and pick options}
  71.   const
  72.     Bord : array[Boolean] of Byte = (0, 1);
  73.   var
  74.     Cols : Byte;
  75.     Rows : Byte;
  76.   begin
  77.     mlFields := NumFields;
  78.     mlString := StringProc;
  79.  
  80.     {Assure rows come out even}
  81.     if (Y2-Y1+1) mod NumFields <> 0 then begin
  82.       Y2 := Y1-1+NumFields*(((Y2-Y1+1) div NumFields)+1);
  83.       while Y2+Bord[LongFlagIsSet(Options, wBordered)] > ScreenHeight do
  84.         dec(Y2, NumFields);
  85.       if Y2 < Y1 then begin
  86.         InitStatus := epFatal+ecWinCoordsBad;
  87.         Fail;
  88.       end;
  89.     end;
  90.  
  91.     if not InitAbstractDeluxe(X1, Y1, X2, Y2, Colors, Options,
  92.                               ItemWidth, NumRecords*NumFields,
  93.                               PickSnaking, SingleChoice, PickOptions) then
  94.       Fail;
  95.   end;
  96.  
  97.   function MultiLinePickList.Item2Record(Item : Word) : Word;
  98.     {-Return the record number corresponding to given Item}
  99.   begin
  100.     Item2Record := ((Item-1) div mlFields)+1;
  101.   end;
  102.  
  103.   procedure MultiLinePickList.ItemString(Item : Word; Mode : pkMode;
  104.                                          var IType : pkItemType;
  105.                                          var IString : String);
  106.     {-Supplies each item string when the list is displayed or searched}
  107.   var
  108.     RecNumZero : Word; {Zero-based record number}
  109.     FieldNum : Word;
  110.     RecIsCurrent : Boolean;
  111.     Attr : Byte;
  112.   begin
  113.     {Compute the record and field number}
  114.     RecNumZero := (Item-1) div mlFields;
  115.     FieldNum := Item-mlFields*RecNumZero;
  116.  
  117.     {Only the first field of each record is unprotected}
  118.     if FieldNum <> 1 then
  119.       IType := pkProtected;
  120.  
  121.     {Get out quick if we just need the item type}
  122.     if Mode = pkGetType then
  123.       Exit;
  124.  
  125.     RecIsCurrent := (RecNumZero = (GetLastChoice-1) div mlFields);
  126.  
  127.     {Get the string}
  128.     mlString(RecNumZero+1, FieldNum, RecIsCurrent, IString, @Self);
  129.  
  130.     {Fix up the protected attributes}
  131.     if FieldNum <> 1 then begin
  132.       if RecIsCurrent then
  133.         Attr := pkColorPtr^[pkNormal, True][0]
  134.       else
  135.         Attr := pkColorPtr^[pkNormal, False][0];
  136.       pkColorPtr^[pkProtected, False][0] := Attr;
  137.     end;
  138.   end;
  139.  
  140.   procedure MultiLinePickList.pkUpdatePick(pFirst, pChoice : Word;
  141.                                            pRow, pCol : Byte);
  142.   begin
  143.     {Draw the whole page every time so protected items are correctly updated}
  144.     pkDrawPage(True);
  145.     if pkFirst <> pFirst then
  146.       if pkMoreRec.HdrNum <> 255 then
  147.         pkUpdateMoreRec(pkMoreRec, (pkFirst > 1),
  148.                         (pkFirst < pkMaxFirst),
  149.                         (pkItemRows > pkHeight));
  150.     {$IFDEF UseScrollBars}
  151.     pkUpdScrBar(@Self);
  152.     {$ENDIF}
  153.   end;
  154.  
  155. end.
  156.