From: "Eddie Shipman" <Eddie@acadsoft.com>
Subject: Re: I will made a Rainborrow with two or more colors !
Date: 24 Jun 1999 00:00:00 GMT
Message-ID: <7ktnna$d2114@forums.borland.com>
References: <37724E4C.5A37E97C@fh-trier.de>
X-Priority: 3
X-MimeOLE: Produced By Microsoft MimeOLE V5.00.2314.1300
Organization: Another Netscape Collabra Server User
X-MSMail-Priority: Normal
Newsgroups: borland.public.delphi.graphics

Here's some source I found a while back about pallete shifting that makes
a cool rainbow background on the form. It won't work on some NT systems.

unit rainbow;

interface

uses
  SysUtils, WinTypes, Forms, ExtCtrls, Classes, Messages, Graphics;


type
  TForm1 = class(TForm)
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormClick(Sender: TObject);
    procedure Timer2Timer(Sender: TObject; var Done : Boolean);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private declarations }
    BluePalette : HPALETTE;
    UsingOurPalette : Boolean;
    SaverKind : Word;
  protected
    procedure WMQueryNewPalette(var Message : TMessage); message
                                    WM_QUERYNEWPALETTE;
    procedure WMPaletteChanged(var Message : TMessage); message
                                   WM_PALETTECHANGED;
    procedure PaletteChanged(var Message : TMessage);
  public
    { Public declarations }
    function GetPalette : HPALETTE; override;
end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

Var
  Pal : PLogPalette;
  PalSize : Word;

type
  TFadeDirection = (fdIn, fdOut);

Procedure CursorOff;
Var
  Cstate : Integer;
Begin
  Cstate := ShowCursor(True);
  While Cstate >= 0 do
    Cstate := ShowCursor(False);
End;

Procedure CursorOn;
Var
  Cstate : Integer;
Begin
  Cstate := ShowCursor(True);
  While Cstate < 0 do
    Cstate := ShowCursor(True);
End;

procedure TForm1.PaletteChanged(var Message : TMessage);
var
  hOldPal : THandle;
  wTemp : Word;
begin
  hOldPal := SelectPalette(Canvas.Handle, BluePalette, False);
  wTemp := RealizePalette(Canvas.Handle);
  SelectPalette(Canvas.Handle, hOldPal, True);
  RealizePalette(Canvas.Handle);
  if wTemp <> 0
    Then
      Invalidate;
  Message.Result := wTemp;
end;

procedure TForm1.WMQueryNewPalette(var Message : TMessage);
begin
  PaletteChanged(Message);
  inherited;
end;


procedure TForm1.WMPaletteChanged(var Message : TMessage);
begin
  if Message.wparam <> handle
    then
      Begin
        PaletteChanged(Message);
        UsingOurPalette := False;
      End
    else
      UsingOurPalette := True;
  inherited;
end;


procedure MakeGradient(R1, G1, B1, R2, G2, B2, Steps : Integer;
                       var palPalEntry : array of TPaletteEntry);
  var
    RStep, GStep, BStep : Real;
    RNow, GNow, BNow : Real;
    i : Integer;
begin
  RStep := (R2-R1)/Steps;
  GStep := (G2-G1)/Steps;
  BStep := (B2-B1)/Steps;
  RNow := R1;
  GNow := G1;
  BNow := B1;
  for i := 0 to Steps - 2 do
    begin
      with palPalEntry[i] do
        begin
          peRed := Round(RNow);
          peGreen := Round(GNow);
          peBlue := Round(BNow);
        end;
      RNow := RNow + RStep;
      GNow := GNow + GStep;
      BNow := BNow + BStep;
    end;
  with palPalEntry[Steps - 1] do
    begin
      peRed := R2;
      peGreen := G2;
      peBlue := B2;
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  xHDC : HDC;
  nStaticColors : Word;
  I : Word;
  BlackPal : PLogPalette;
begin
  Randomize;
  SaverKind := Random(2);
  If SaverKind = 1
    Then
      Color := clBlack;
  Application.OnIdle := Timer2Timer;
  PalSize := SizeOf(TLogPalette) + 255 * SizeOf(TPaletteEntry);
  GetMem(Pal, PalSize);
  With Pal^ do
    Begin
      palVersion := $0300;
      palNumEntries := 256;
      xHDC := Canvas.Handle;
  { This assumes SYSPAL_STATIC, but will work under SYSPAL_NOSTATIC; if
    you need more colors, check out GetSystemPaletteUse and
SetSystemPaletteUse
    Get the twenty static colors into the array, then fill in the empty
    spaces with the given color table }

    { Get the static colors from the system palette }
    nStaticColors := GetDeviceCaps(xHDC, NUMRESERVED);
    if nStaticColors = 0
      Then
        nStaticColors := 20; { "Fake" static colors }
    GetSystemPaletteEntries(xHDC, 0, 256, palPalEntry);
    { Set the peFlags of the lower static colors to zero }
    nStaticColors := nStaticColors shr 1; { half at bottom, half at top}
    for i:= 0 to (nStaticColors-1) do
      palPalEntry[i].peFlags := 0;

    I := 0;
    MakeGradient(255,   0,   0, 255, 127,   0, 40, palPalEntry[ i+10]);
    MakeGradient(255, 127,   0, 255, 255,   0, 40, palPalEntry[ i+49]);
    MakeGradient(255, 255,   0,   0, 255,   0, 40, palPalEntry[ i+88]);
    MakeGradient(  0, 255,   0,   0,   0, 255, 41, palPalEntry[i+128]);
    MakeGradient(  0,   0, 255, 255,   0, 255, 41, palPalEntry[i+168]);
    MakeGradient(255,   0, 255, 255,   0,   0, 40, palPalEntry[i+206]);

    For I := 0 to 235 do
      With palPalEntry[nStaticColors + I] do
        peFlags :=PC_RESERVED; { Prepare for palette animation }

    { Mark empty entries as PC_NOCOLLAPSE }
    for i := (nStaticColors + 236) to (255-nStaticColors) do
      palPalEntry[i].peFlags := PC_NOCOLLAPSE;

    { Set the peFlags of the upper static colors to zero }
    for i := (256 - nStaticColors) to 255 do
      palPalEntry[i].peFlags := 0;

    GetMem(BlackPal, PalSize);
    Move(Pal^, BlackPal^, PalSize);
    I := 10;
    FillChar(BlackPal^.palPalEntry[I], SizeOf(TPALETTEENTRY) * 236, 0);
    For I := 10 to 245 do
      BlackPal^.palPalEntry[I].peFlags := PC_RESERVED;
    BluePalette := CreatePalette(BlackPal^);
    FreeMem(BlackPal, PalSize);
    end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  { Delete the palette we created earlier }
  DeleteObject(BluePalette);
  FreeMem(Pal, PalSize);
end;

function TForm1.GetPalette : HPALETTE;
begin
  Result := BluePalette;
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  OldPal : HPALETTE;
  YPos, BarWidth : Real;
  i : Word;
begin
  OldPal := SelectPalette(Canvas.Handle, BluePalette, True);
  RealizePalette(Canvas.Handle);
  BarWidth := clientheight / 236;
  Case SaverKind of
    0 : Begin
  YPos := 0;
  For i := 10 to 245 do
    begin
      If UsingOurPalette
        Then
          canvas.brush.color := PaletteIndex(i)
        Else
          with Pal^.palPalEntry[i] do
            canvas.brush.color := RGB(peRed, peGreen, peBlue);
       canvas.fillrect(rect(0, Round(YPos),
                       ClientWidth - 1, Round(YPos + BarWidth)));
      YPos := YPos + BarWidth;
    end;
        End;
    End;
  SelectPalette(Canvas.Handle, OldPal, True);
  RealizePalette(Canvas.Handle);
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Invalidate;
end;

procedure Fade(Steps : Word; MyPal : PLogPalette;
               BluePalette : HPALETTE; Dir : TFadeDirection);
type
  TRealPalEntry = Record
    reRed : Real;
    reGreen : Real;
    reBlue : Real;
    End;
  TRealPal = Array[0..255] of TRealPalEntry;

var
  OldPal : HPalette;
  FadeRealPal : ^TRealPal;
  FadeStepsPal : ^TRealPal;
  FinalPal : PLogPalette;
  I, J : Word;
  Ten : Word;
  TempPalette : HPalette;
  PalSize : Word;
  Pal : PLogPalette;

begin
  Ten := 10;
  GetMem(FadeRealPal, SizeOf(TRealPalEntry) * 236);
  GetMem(FadeStepsPal, SizeOf(TRealPalEntry) * 236);
  PalSize := SizeOf(TLogPalette) + 255 * SizeOf(TPaletteEntry);
  GetMem(Pal, PalSize);
  GetMem(FinalPal, PalSize);
  Move(MyPal^, Pal^, PalSize);
  Move(Pal^, FinalPal^, PalSize);
  {$R-}
  If Dir = fdOut
    Then
      For I := 0 to 235 do
        With FadeStepsPal^[I], Pal^.palPalEntry[I+10] do
          begin
            reRed := -peRed / Steps;
            reBlue := -peBlue / Steps;
            reGreen := -peGreen / Steps;
          end
    Else
      For I := 0 to 235 do
        With FadeStepsPal^[I], Pal^.palPalEntry[I+10] do
          begin
            reRed := peRed / Steps;
            reBlue := peBlue / Steps;
            reGreen := peGreen / Steps;
          end;
  if Dir = fdIn
    Then
      Begin
        FillChar(Pal^.palPalEntry[Ten], SizeOf(TPALETTEENTRY) * 236, 0);
        FillChar(FadeRealPal^, SizeOf(TRealPalEntry) * 236, 0);
      End
    Else
      Begin
        FillChar(FinalPal^.palPalEntry[Ten], SizeOf(TPALETTEENTRY) * 236,
0);
        For I := 0 to 235 do
          With FadeRealPal^[I], Pal^.palPalEntry[I+10] do
            begin
              reRed := peRed;
              reBlue := peBlue;
              reGreen := peGreen;
            end
      End;

  For I := 0 to 235 do
    begin
      Pal^.palPalEntry[I+10].peFlags := PC_RESERVED;
      FinalPal^.palPalEntry[I + 10].peFlags := PC_RESERVED;
    end;

  For I := 1 to Steps - 1 do
    Begin
      AnimatePalette(BluePalette, 10, 236, Addr(Pal^.palPalEntry[Ten]));

      For J := 0 to 235 do
        Begin
          With FadeRealPal^[J] do
            Begin
              reRed := reRed + FadeStepsPal^[J].reRed;
              reGreen := reGreen + FadeStepsPal^[J].reGreen;
              reBlue := reBlue + FadeStepsPal^[J].reBlue;
            End;
          With Pal^.palpalEntry[J+10] do
            Begin
              peRed := Round(FadeRealPal^[J].reRed);
              peGreen := Round(FadeRealPal^[J].reGreen);
              peBlue := Round(FadeRealPal^[J].reBlue);
            End;
        End;
    End;
  AnimatePalette(BluePalette, 10, 236, Addr(FinalPal^.palPalEntry[Ten]));
  FreeMem(FinalPal, PalSize);
  FreeMem(Pal, PalSize);
  FreeMem(FadeRealPal, SizeOf(TRealPalEntry) * 236);
  FreeMem(FadeStepsPal, SizeOf(TRealPalEntry) * 236);
end;

const
  Started : Boolean = False;
  BallColor : Word = 245;
  YDir : Integer = -2;
  XDir : Integer = 1;
  RX : Integer = 100;
  RY : Integer = 200;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  Temp : TPALETTEENTRY;
  F, G : Word;
  OldPal : HPalette;
const
  PalStart : word = 10;
  PalEnd : word = 245;
begin
  If not Started
    Then
      Started := True;
  With pal^ do
    Begin
      Temp := palPalEntry[palStart];
      For F := palStart to (palEnd - 1) do
        palPalEntry[F] := palPalEntry[F+1];
      palPalEntry[palEnd] := Temp;
      AnimatePalette(BluePalette, PalStart, (PalEnd + 1 -
PalStart),Addr(palPalEntry[palStart]))
    End;
  OldPal := SelectPalette(Canvas.Handle, BluePalette, True);
  RealizePalette(Canvas.Handle);
  Case SaverKind of
    1 :
      Begin
  canvas.brush.color := PaletteIndex(BallColor);
  canvas.fillrect(Rect(RX, RY, RX+20, RY+20));
  Inc(RX, XDir);
  If (RX + 20 >= clientwidth) or (RX < 0)
    Then
      XDir := -XDir;
  Inc(RY, YDir);
  If (RY+20 >= clientheight) or (RY < 0)
    Then
      YDir := -YDir;
  Dec(BallColor);
  If BallColor = 9
    Then
      BallColor := 245;
      End;
    End;
  SelectPalette(Canvas.Handle, OldPal, True);
  RealizePalette(Canvas.Handle);
end;


procedure TForm1.FormClick(Sender: TObject);
begin
  If Started
    Then
      Begin
        Fade(128, Pal, BluePalette, fdOut);
        Close;
      End;
end;

const
  FirstTime : Boolean = True;

procedure TForm1.Timer2Timer(Sender: TObject; var Done: Boolean);
begin
  If FirstTime
    Then
      Begin
        FirstTime := False;
        Fade(128, Pal, BluePalette, fdIn);
        Timer1.Enabled := True;
        Done := False;
      End;
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
  FormClick(Sender);
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  FormClick(Sender);
end;

end.

Wilhelm Steinbuß <steinbus@fh-trier.de> wrote in message
news:37724E4C.5A37E97C@fh-trier.de...
> Hi,
>
> I will made a rainborrow with two or more colors.
>
> A little procedure like:
>
> procedure (color1, color2:TColor; canvas: TCanvas);
> begin
> ....
> end;
>
> And this procedure should made the rainborrow in Canvas.
> In the top the color color1 and in the bottom the color color2 !