home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / pascal / shdk_1.zip / TESTCOLR.PAS < prev    next >
Pascal/Delphi Source File  |  1992-03-23  |  5KB  |  157 lines
  1. program TestColr;
  2. {
  3.              To test the SelectColors function of ShClrDef
  4.  
  5.                   Copyright 1991 Madison & Associates
  6.                           All Rights Reserved
  7.  
  8.          This program source file and the associated executable
  9.          file may be  used and distributed  only in  accordance
  10.          with the  provisions  described  on  the title page of
  11.                   the accompanying documentation file
  12.                               SKYHAWK.DOC
  13. }
  14.  
  15. uses
  16.   TpString,
  17.   TpCrt,
  18.   TpEdit,
  19.   ShClrDef;
  20.  
  21. var
  22.   EraseP,
  23.   EraseC,
  24.   WrapCursor,
  25.   Quit      : boolean;
  26.   C1        : char;
  27.   MsgRow,
  28.   YNcol,
  29.   B1,B2,
  30.   Xhi,Yhi,
  31.   Xloc,Yloc : byte;
  32.   MaxMem,
  33.   AvailMem  : longint;
  34.   XY        : word;
  35.   ScrnBuf   : pointer;
  36.  
  37. function StopRun : boolean;
  38.   begin
  39.     StopRun := (not YesOrNo('Again? » ', MsgRow+2, YNcol, $70, 'Y'));
  40.     end;
  41.  
  42. begin
  43.   {Record the environment}
  44.   {Un-comment the following lines if you wish to check that the heap is
  45.    being completely restored. Also un-comment the lines at the end of the
  46.    program file.}
  47. (**)
  48.   MaxMem := MemAvail;           {Total unused heap space}
  49.   AvailMem := MaxAvail;         {Largest contiguous heap block};
  50. (**)
  51.   Xhi := ScreenWidth;
  52.   Yhi := ScreenHeight;
  53.  
  54.   {Locate the panel}
  55.   WriteLn('Locate the color panel where?');
  56.   Write  ('     Row coordinate [0..',(ScreenHeight-17):2,', 255]  » ');
  57.   ReadLn(Yloc);
  58.   Write  ('     Col coordinate [0..',(ScreenWidth -25):2,', 255]  » ');
  59.   ReadLn(Xloc);
  60.  
  61.   {Erase the panel on exit from SelectColors?}
  62.   Write  ('Erase panel? [T/F]   » '); C1 := UpCase(ReadKey);
  63.   while not (C1 in ['T','F']) do begin
  64.     Write(^G);
  65.     C1 := UpCase(ReadKey);
  66.     end;
  67.   WriteLn(C1);
  68.   EraseP := (C1 = 'T');
  69.  
  70.   if not EraseP then begin
  71.     {Erase the Cursor on exit from SelectColors?}
  72.     Write  ('Erase cursor? [T/F]  » '); C1 := UpCase(ReadKey);
  73.     while not (C1 in ['T','F']) do begin
  74.       Write(^G);
  75.       C1 := UpCase(ReadKey);
  76.       end;
  77.     WriteLn(C1);
  78.     EraseC := (C1 = 'T');
  79.     end;
  80.  
  81.   {Allow cursor wrap at window edges?}
  82.   Write  ('Wrap cursor? [T/F]   » '); C1 := UpCase(ReadKey);
  83.   while not (C1 in ['T','F']) do begin
  84.     Write(^G);
  85.     C1 := UpCase(ReadKey);
  86.     end;
  87.   WriteLn(C1);
  88.   WrapCursor := (C1 = 'T');
  89.  
  90.   {Locate the message row according to panel position.}
  91.   if Yloc >= 4 then
  92.     MsgRow := 1
  93.   else
  94.     MsgRow := ScreenHeight - 3;
  95.   YNcol := (ScreenWidth shr 1) - 7;
  96.  
  97.   {Do the color selection}
  98.   XY := WhereXY;
  99.   if not
  100.     SaveWindow(1, 1, ScreenWidth, ScreenHeight, true, ScrnBuf) then;
  101.   ClrScr;
  102.   B1 := BlackOnBlack;
  103.   repeat
  104.     B1 := SelectColors
  105.           (Yloc,Xloc,B1,FrameChars,Vertical,
  106.            EraseP,EraseC,WrapCursor,' Color Panel ');
  107.     case B1 of
  108.       $FF : begin
  109.               B1 := B2;
  110.               FastWrite(
  111.               Center('Re-written in '+ColorName(B1), Xhi),
  112.                       MsgRow, 1, B1);
  113.               Quit := StopRun;
  114.               FastWrite('                ', MsgRow+2, YNcol, BlackOnBlack);
  115.               end;
  116.       $F0 : FastWrite(
  117.             Center('Error in MakeWindow', Xhi),
  118.                     MsgRow, 1, $07);
  119.       $F1 : FastWrite(
  120.             Center('Error in DisplayWindow', Xhi),
  121.                     MsgRow, 1, $07);
  122.       $F2 : FastWrite(
  123.             Center('Row parameter out of range', Xhi),
  124.                     Yhi shr 1, 1, $07);
  125.       $F3 : FastWrite(
  126.             Center('Column parameter out of range', Xhi),
  127.                     Yhi shr 1, 1, $07);
  128.       else begin
  129.              FastWrite(
  130.                Center('Written in '+ColorName(B1), Xhi),
  131.                        MsgRow, 1, B1);
  132.              B2 := B1;
  133.              Quit := StopRun;
  134.              FastWrite('                ', MsgRow+2, YNcol, BlackOnBlack);
  135.              end; {else}
  136.       end; {case B1}
  137.     until Quit or ((B1 >= $F0) and (B1 < $FF));
  138.  
  139.   {Kick out on any error}
  140.   if (B1 >= $F0) and (B1 < $FF) then begin
  141.     GoToXY(1, (Yhi shr 1) +2);
  142.     Write(^G+TrimTrail(Center('Any key to return to DOS... » ', Xhi)));
  143.     if ReadKey = '' then ;
  144.     end;
  145.   RestoreWindow(1, 1, ScreenWidth, ScreenHeight, true, ScrnBuf);
  146.   GoToXYabs(lo(XY), hi(XY));
  147.   {Display residual heap -- should be none}
  148.   {Un-comment the following lines if you wish to check that the heap is
  149.    being completely restored.}
  150. (**)
  151.   WriteLn('Total heap at start = ',MaxMem);
  152.   WriteLn('Total heap at end   = ',MemAvail);
  153.   WriteLn('Largest contiguous block on heap at start = ',AvailMem);
  154.   WriteLn('Largest contiguous block on heap at end   = ',MaxAvail);
  155. (**)
  156.   end.
  157.