home *** CD-ROM | disk | FTP | other *** search
/ Chip: Shareware for Win 95 / Chip-Shareware-Win95.bin / ostatni / delphi / delphi1 / anipal.exe / PALS.PAS < prev   
Pascal/Delphi Source File  |  1995-09-05  |  5KB  |  189 lines
  1. {
  2.     Project: Palette
  3.     Company: Word in Action
  4.              Copyright (C) 1995 by Jay Giganti.  All Rights Reserved.
  5.  
  6.     File    : Pals.Pas
  7.     Author  : Jay Giganti
  8.     Overview: To Modify the color palette and display a road to nowhere
  9. }
  10.  
  11. unit Pals;
  12.  
  13. interface
  14.  
  15. uses
  16.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  17.   Forms, Dialogs, ExtCtrls, StdCtrls;
  18.  
  19. type
  20.   TForm1 = class(TForm)
  21.     Timer1: TTimer;
  22.     Panel1: TPanel;
  23.     Image1: TImage;
  24.     Button1: TButton;
  25.     procedure FormCreate(Sender: TObject);
  26.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  27.     procedure Timer1Timer(Sender: TObject);
  28.     procedure Button1Click(Sender: TObject);
  29.   private
  30.     { Private declarations }
  31.  
  32.     function  GetPalette: HPALETTE; override;
  33.     procedure CreatePal;
  34.     procedure PaintImg;
  35.  
  36.   public
  37.     { Public declarations }
  38.   end;
  39.  
  40. var
  41.   Form1: TForm1;
  42.  
  43. implementation
  44.  
  45. const
  46.   Entries  = 256;
  47.   Clrs     = Trunc(Entries / 4);
  48.  
  49. var
  50.   CurPal  : Array[0..Entries-1] of TPALETTEENTRY;
  51.   hPal    : HPalette;
  52.   hOldPal : HPalette;
  53. {==============================================================================
  54.                                  CreatePal
  55. ==============================================================================}
  56. procedure TForm1.CreatePal;
  57. var
  58.   nCntr : Integer;
  59.   pPal  : PLOGPALETTE;
  60.   lSize : LongInt;
  61. begin
  62.  
  63.   lSize               := sizeof(TLogPalette) + Entries * sizeof(TPaletteEntry);
  64.   pPal                := MemAlloc(lSize);
  65.   pPal^.palVersion    := $300;
  66.   pPal^.palNumEntries := Entries;
  67.  
  68.   {$R-}
  69.   for nCntr := 0 to Clrs do
  70.   begin
  71.           { Set up the shades of Gray }
  72.     pPal^.palPalEntry[nCntr].peRed   := nCntr + 128;
  73.     pPal^.palPalEntry[nCntr].peGreen := nCntr + 128;
  74.     pPal^.palPalEntry[nCntr].peBlue  := nCntr + 128;
  75.     pPal^.palPalEntry[nCntr].peFlags := PC_RESERVED;
  76.  
  77.           { Set up the shades of Red }
  78.     pPal^.palPalEntry[nCntr + Clrs].peRed   := nCntr + 128;
  79.     pPal^.palPalEntry[nCntr + Clrs].peGreen := 0;
  80.     pPal^.palPalEntry[nCntr + Clrs].peBlue  := 0;
  81.     pPal^.palPalEntry[nCntr + Clrs].peFlags := PC_RESERVED;
  82.  
  83.            { Set up the shades of Green }
  84.     pPal^.palPalEntry[nCntr + Clrs*2].peRed   := 0;
  85.     pPal^.palPalEntry[nCntr + Clrs*2].peGreen := nCntr + 128;
  86.     pPal^.palPalEntry[nCntr + Clrs*2].peBlue  := 0;
  87.     pPal^.palPalEntry[nCntr + Clrs*2].peFlags := PC_RESERVED;
  88.  
  89.            { Set up the shades of Blue }
  90.     pPal^.palPalEntry[nCntr + Clrs*3].peRed   := 0;
  91.     pPal^.palPalEntry[nCntr + Clrs*3].peGreen := 0;
  92.     pPal^.palPalEntry[nCntr + Clrs*3].peBlue  := nCntr + 128;
  93.     pPal^.palPalEntry[nCntr + Clrs*3].peFlags := PC_RESERVED;
  94.    end;
  95.  
  96.    for nCntr := 0 to Entries - 1 do
  97.     CurPal[nCntr] := pPal^.palPalEntry[nCntr];
  98.  
  99.    {$R+}
  100.    hPal := CreatePalette(pPal^);
  101.    FreeMem(pPal, lSize);
  102. end;
  103. {$R *.DFM}
  104.  
  105. procedure TForm1.FormCreate(Sender: TObject);
  106. begin
  107.   Width      := 640;
  108.   Height     := 480;
  109.   CreatePal;
  110.   PaintImg;
  111. end;
  112.  
  113.  
  114. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
  115. begin
  116.   SelectPalette(Image1.Canvas.Handle, hOldPal, FALSE);
  117.   RealizePalette(Image1.Canvas.Handle);
  118.   DeleteObject(hPal);
  119. end;
  120.  
  121. function TForm1.GetPalette: HPALETTE;
  122. begin
  123.   Result := hPal;
  124. end;
  125.  
  126. procedure TForm1.Timer1Timer(Sender: TObject);
  127. var
  128.   Pal   : TPALETTEENTRY;
  129.   nCntr : Integer;
  130. begin
  131.   Pal := CurPal[0];
  132.   for nCntr := 0 to Entries - 2 do
  133.     CurPal[nCntr] := CurPal[nCntr + 1];
  134.   CurPal[nCntr+1] := Pal;
  135.   AnimatePalette(hPal, 0, Entries, CurPal);
  136. end;
  137.  
  138. procedure TForm1.PaintImg;
  139. var
  140.  Clr   : LongInt;
  141.  y,
  142.  x1,
  143.  clrS,
  144.  clrE,
  145.  x2    : Integer;
  146.  wReal : WORD;
  147.  
  148. begin
  149.   clrS := 21;
  150.   clrE := 22;
  151.   x1   := ClientWidth DIV 2;
  152.   x2   := x1;
  153.   Clr  := clrS;
  154.  
  155.   hOldPal    := SelectPalette(Image1.Canvas.Handle, hPal, FALSE);
  156.   wReal      := RealizePalette(Image1.Canvas.Handle);
  157.   Panel1.Caption:= Format('Realized %u Entries out of %u',
  158.                           [wReal, Entries]);
  159.  
  160.   Image1.Canvas.Brush.Color := PaletteIndex(1);
  161.   Image1.Canvas.FillRect(Rect(0, 0, Image1.Width, Image1.Height));
  162.  
  163.   for y := 120 to ClientHeight - 120 do
  164.   begin
  165.     Image1.Canvas.Pen.Color := PaletteIndex(Clr);
  166.     Image1.Canvas.MoveTo(x1, y);
  167.     Image1.Canvas.LineTo(x2, y);
  168.  
  169.     Dec(x1);
  170.     if x1 < 0 then
  171.       x1 := 0;
  172.  
  173.     Inc(x2);
  174.     if (x2 > ClientWidth) then
  175.       x2 := ClientWidth;
  176.  
  177.     Inc(Clr);
  178.     if (clr > Entries - clrE) then
  179.       Clr := ClrS;
  180.   end;
  181. end;
  182.  
  183. procedure TForm1.Button1Click(Sender: TObject);
  184. begin
  185.   Timer1.Enabled := not Timer1.Enabled;
  186. end;
  187.  
  188. end.
  189.