home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / toolkid / getcolor.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-04-05  |  7.4 KB  |  230 lines
  1. UNIT GETCOLOR;
  2. INTERFACE
  3.   USES CRT,IOSTUFF;
  4.   PROCEDURE SetChooseColor(X,Y : Integer);
  5.   PROCEDURE ChooseColor(VAR Fore,Back : Integer);
  6. IMPLEMENTATION
  7. VAR
  8.       XPos        : Integer;  {These two varibles control the location}
  9.       YPos        : Integer;   {of the color box on the screen}
  10. {======================================================================}
  11. PROCEDURE SetChooseColor(X,Y : Integer);
  12. BEGIN
  13.   If X < 1 then X := 1;
  14.   If Y < 1 then Y := 1;
  15.   If X + 52 < 81 then XPos := X else XPos := 28;
  16.   If Y + 8 < 26 then YPos := Y else YPos := 17;
  17. END;
  18.  
  19. {======================================================================}
  20. PROCEDURE ChooseColor(VAR Fore,Back : Integer);
  21.  
  22. { ChooseColor Pops up a color selection smorgasbord on the screen   }
  23. { and allows the user to select the background and foreground colors}
  24. { desired by playing with the smorgasbord.  When the user exits     }
  25. { the procedure, the selected colors are returned in Fore and  }
  26. { Back.  The only outside procedure needed is SetColor.        }
  27. { The logic to turn the cursor off and on should be placed external }
  28. { in procedures CursorOff and CursorOn, for example, if they are    }
  29. { needed elsewhere in the main program.                             }
  30. { Constants XPos and YPos control the position of the upper left    }
  31. { hand corner of the color selection smorgasbord box.               }
  32.  
  33. CONST
  34.       Phrase               : Array[1..3] of String[20] =
  35.                              ('ForeGround:',
  36.                               'BackGround:',
  37.                               'Quit & Lock Colors');
  38.  
  39.       FirstLet   :  Array[1..3] of Char = ('F','B','Q');
  40.  
  41.  
  42.       EscKey     = #27;       { Keys acted on in color selection }
  43.       DownArrow  = #80;
  44.       UpArrow    = #72;
  45.       RightArrow = #77;
  46.       LeftArrow  = #75;
  47.       EnterKey   = #13;
  48.  
  49.       ColorF1    = Green;     { Foreground color - menu phrases }
  50.       ColorB1    = Black;     { Background color - menu phrases }
  51.       ColorF2    = Magenta;   { Foreground color - border       }
  52.       ColorB2    = Black;     { Background color - border       }
  53.       ColorF3    = LightCyan; { Foreground color - first letter of menu }
  54.       ColorB3    = Black;     { Background color - first letter of menu }
  55.       ColorF4    = Black;     { Foreground color - reverse menu }
  56.       ColorB4    = LightGray; { Background color - reverse menu }
  57.       ColorF5    = LightRed;  { Foreground color - arrow }
  58.       ColorB5    = Black;     { Background color - arrow }
  59.  
  60.  
  61. VAR
  62.       II          : Integer;
  63.       FBQ         : Integer;       { 1,2 or 3 depending on whether   }
  64.       LastFBQ     : Integer;       { Fore, Back or Quit is selected. }
  65.       CCh         : Char;
  66.       ColorExit   : Boolean;
  67.       FunctKey    : Boolean;
  68.       SaveAttr    : Byte;
  69.  {======================================================================}
  70.   PROCEDURE DrawSample;
  71.   BEGIN
  72.             { show a sample of the color selected }
  73.         SetColor(Fore,Back);
  74.         WriteSt('╒═══════════════════╕',XPos+32,YPos+2);
  75.         WriteSt('│  SAMPLE OF COLOR  │',XPos+32,YPos+3);
  76.         WriteSt('╘═══════════════════╛',XPos+32,YPos+4);
  77.   END;
  78. {======================================================================}
  79. PROCEDURE ShowTopArrow;
  80. BEGIN
  81.    SetColor(ColorF5,ColorB5);
  82.    WriteSt('                ',XPos+13,YPos+1);
  83.    WriteCh(chr(25),XPos+13+Fore,YPos+1);
  84. END;
  85. {======================================================================}
  86. PROCEDURE ShowBottomArrow;
  87. BEGIN
  88.    SetColor(ColorF5,ColorB5);
  89.    WriteSt('                ',XPos+13,YPos+3);
  90.    WriteCh(chr(25),XPos+13+Back,YPos+3);
  91. END;
  92.  
  93. {======================================================================}
  94. BEGIN
  95.    If (Fore < 0) or (Fore > 15) then Fore := LightGray;
  96.    If (Back < 0) or (Back > 15) then Back := Black;
  97.    SaveAttr  := TextAttr;
  98.    ColorExit := False;
  99.    HideCursor;
  100.    SetColor(ColorF2,ColorB2);
  101.    Window(XPos,YPos,XPos+30,YPos+8);
  102.    ClrScr;
  103.    Window(1,1,80,25);
  104.    Border(XPos,YPos,XPos+30,YPos+8,'CHOOSE COLOR');
  105.  
  106.          {Write the menu phrases}
  107.    For II := 1 to 3 do
  108.     Begin
  109.      SetColor(ColorF1,ColorB1);
  110.      WriteSt(Phrase[II],Xpos+2,YPos+II*2);
  111.      SetColor(ColorF3,ColorB3);
  112.      WriteCh(FirstLet[II],XPos+2,YPos+II*2);
  113.     End;
  114.  
  115.          {Write the color dots}
  116.    For II := 0 to 15 do
  117.    Begin
  118.      Setcolor(II,ColorB1);
  119.      WriteSt(chr(254),II+XPos+13,YPos+2);
  120.      If II = 8 then SetColor(LightGray,II)
  121.                else SetColor(ColorB1,II);
  122.      WriteCh(chr(254),II+XPos+13,YPos+4);
  123.    End;
  124.  
  125.          {Get ready for the key reading loop}
  126.     FBQ := 1;
  127.     LastFBQ := 0;
  128.     DrawSample;
  129.     ShowTopArrow;
  130.     ShowBottomArrow;
  131.         {Start Big key reading loop}
  132.   Repeat
  133.  
  134.               {write the reverse video menu phrase}
  135.        If LastFBQ <> FBQ then Begin
  136.          SetColor(ColorF4,ColorB4);
  137.          WriteSt(Phrase[FBQ],XPos+2,YPos+FBQ*2);
  138.  
  139.               {restore the last reverse video menu phrase}
  140.          If LastFBQ <> 0 then Begin
  141.            SetColor(ColorF1,ColorB1);
  142.            WriteSt(Phrase[LastFBQ],XPos+2,YPos+LastFBQ*2);
  143.            SetColor(ColorF3,ColorB3);
  144.            WriteCh(FirstLet[LastFBQ],XPos+2,YPos+LastFBQ*2);
  145.          End;
  146.        End;
  147.               { remember the last FBQ Index }
  148.        LastFBQ := FBQ;
  149.  
  150.        CCh := Readkey;        {read a keystroke}
  151.        If CCh <> #0 then FunctKey := False else
  152.         Begin
  153.           CCh := Readkey;
  154.           FunctKey := True;
  155.         End;
  156.  
  157.     If not FunctKey then Case CCh of
  158.  
  159.       'F','f': FBQ := 1;                    {got an F key, Foreground}
  160.       'B','b': FBQ := 2;                    {got a B key, Background }
  161.       'Q','q',EscKey : ColorExit := True;    {got a Q or Escape key, quit}
  162.  
  163.       EnterKey : Begin                       {got an enter key}
  164.                   If FBQ < 3 then FBQ := Succ(FBQ)
  165.                   Else ColorExit := True;
  166.                  End;
  167.  
  168.       Else Beep;                             {beep on any other key}
  169.  
  170.     End; {case non function keys}
  171.  
  172.             {process function keys (cursor pad)}
  173.    If FunctKey then Case CCh of
  174.    DownArrow : Begin
  175.                 If FBQ < 3 then FBQ := FBQ+1
  176.                 Else FBQ := 1;
  177.                End;
  178.  
  179.    UpArrow   : Begin
  180.                 If FBQ > 1 then FBQ := FBQ - 1
  181.                 Else FBQ := 3;
  182.                End;
  183.  
  184.    RightArrow : Case FBQ of
  185.           1: Begin
  186.               If Fore < 15 then Fore := Succ(Fore)
  187.                                 else Fore := 0;
  188.               DrawSample;
  189.               ShowTopArrow;
  190.              End;
  191.           2: Begin
  192.               If Back < 15 then Back := Succ(Back)
  193.                                 else Back := 0;
  194.               DrawSample;
  195.               ShowBottomArrow;
  196.              End;
  197.           3: Beep;
  198.           End; {case FBQ}
  199.  
  200.    LeftArrow : Case FBQ of
  201.           1: Begin
  202.               If Fore > 0 then Fore := Pred(Fore)
  203.                                else Fore := 15;
  204.               DrawSample;
  205.               ShowTopArrow;
  206.              End;
  207.           2: Begin
  208.               If Back > 0 then Back := Pred(Back)
  209.                                else Back := 15;
  210.               DrawSample;
  211.               ShowBottomArrow;
  212.              End;
  213.           3: Beep;
  214.          End; {case}
  215.  
  216.    Else Beep;
  217.    End; {case function keys}
  218.  
  219. Until ColorExit;     {bottom of keystroke loop}
  220.  
  221. ShowCursor;
  222. TextAttr := SaveAttr;
  223.  
  224. END;
  225.  
  226. BEGIN  {Initialization}
  227.   XPos := 20;
  228.   YPos := 5;
  229.  
  230. END. {UNIT}