Rainbow Gradient Hintergrund

Wilhelm Steinbuß wrote in message
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 !
>

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.

[code lang=”delphi”]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. [/code] [tags]Delphi, Graphic[/tags]