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