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