Živě.cz o počítačích a internetu

Tipy a triky v Delphi, díl 61. - Grafické vylepšení naší aplikace

Jan Šindelář - 9.10.2002

Grafické vylepšení naší aplikace

V našem seriálu už jsme vylepšovali aplikace opravdu rozličnými způsoby. Od tvaru a barev samotného okna, přes úpravu jednotlivých komponent. Ne vždy to samozřejmě bylo účelné a některá tato vylepšení byla spíše pro zábavu a zkoušení. Vše záleží do jisté míry na vašem vkusu, jak moc aplikaci podobnými efekty "přeplácáte". Do podobné kategorie spadá i dnešní tip.

Ukážeme si, jak na pozadí formuláře, které je jinak šedivě (či jinak) nudné, nakreslit duhu. Tedy, ne úplně přesně duhu, ale spíše barevné spektrum. Zkrátka jednotlivé barvy spektra, které postupně přecházejí jedna v druhou.

Příklad se skládá vlastně ze dvou procedur. První slouží k samotnému vykreslování "duhy", druhá pro zjišťování čísla barvy na daném místě duhy (viz. dále). Pohledem do zdrojového kódu můžete vidět, jak jsou postupně kresleny přechody jednotlivých barev. Procedura má postupně parametry, které určují místo, kde bude spektrum kresleno (zde plátno formuláře), dále souřadnice a velikost spektra. Předposledním parametrem určíme, zda má být spektrum horizontální či vertikální a posledním parametrem můžeme zajistit, zda má spektrum opět končit červenou počáteční barvou a uzavřít tak pomyslný "kruh" (což v tomto případě není zrovna přesné vyjádření).

Druhá procedura je spíše takové nepovinné rozšíření pro kontrolu, se samotným kreslením spektra nemá nic společného. Poslouží nám pouze k tomu, že po kliknutí na libovolné místo formuláře se nám zobrazí hodnota barvy, kterou v daném místě spektrum má.

procedure PaintRainbow(Dc : hDc; x : integer; y : integer; Width : integer; Height : integer; bVertical : bool; WrapToRed : bool);
var
  i : integer;
  ColorChunk : integer;
  OldBrush : hBrush;
  r : integer;
  g : integer;
  b : integer;
  Chunks : integer;
  pt : TPoint;
begin
  OffsetViewportOrgEx(Dc, x, y, pt);
  if WrapToRed then Chunks := 6
                else Chunks := 5;
  if bVertical then ColorChunk := Height div Chunks
                else ColorChunk := Width div Chunks;

  {Red -> Yellow}
  r := 255;
  b := 0;
  for i := 0 to ColorChunk do
    begin
    g:= (255 div ColorChunk) * i;
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical then PatBlt(Dc, 0, i, Width, 1, PatCopy)
                else PatBlt(Dc, i, 0, 1, Height, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
    end;

  {Yellow -> Green}
  g:=255;
  b:=0;
  for i := ColorChunk  to (ColorChunk * 2) do
    begin
    r := 255 - (255 div ColorChunk) * (i - ColorChunk);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical then PatBlt(Dc, 0, i, Width, 1, PatCopy)
                else PatBlt(Dc, i, 0, 1, Height, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
    end;

  {Green -> Cyan}
  r:=0;
  g:=255;
  for i:= (ColorChunk * 2) to (ColorChunk * 3) do
    begin
    b := (255 div ColorChunk)*(i - ColorChunk * 2);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical then PatBlt(Dc, 0, i, Width, 1, PatCopy)
                else PatBlt(Dc, i, 0, 1, Height, PatCopy);
    DeleteObject(SelectObject(Dc,OldBrush));
    end;

  {Cyan -> Blue}
  r := 0;
  b := 255;
  for i:= (ColorChunk * 3) to (ColorChunk * 4) do
    begin
    g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical then PatBlt(Dc, 0, i, Width, 1, PatCopy)
                else PatBlt(Dc, i, 0, 1, Height, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
    end;

  {Blue -> Magenta}
  g := 0;
  b := 255;
  for i:= (ColorChunk * 4) to (ColorChunk * 5) do
    begin
    r := (255 div ColorChunk) * (i - ColorChunk * 4);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical then PatBlt(Dc, 0, i, Width, 1, PatCopy)
                else PatBlt(Dc, i, 0, 1, Height, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush))
    end;

  if WrapToRed then
    begin
    {Magenta -> Red}
    r := 255;
    g := 0;
    for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do
    begin
      b := 255 -((255 div ColorChunk) * (i - ColorChunk * 5));
      OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r,g,b)));
      if bVertical then PatBlt(Dc, 0, i, Width, 1, PatCopy)
                  else PatBlt(Dc, i, 0, 1, Height, PatCopy);
      DeleteObject(SelectObject(Dc,OldBrush));
    end;
    end;

  if (Width - (ColorChunk * Chunks) - 1 ) > 0 then
    begin
    if WrapToRed then
    begin
      r := 255;
      g := 0;
      b := 0;
    end
    else
    begin
      r := 255;
      g := 0;
      b := 255;
    end;
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical then PatBlt(Dc, 0, ColorChunk * Chunks, Width, Height - (ColorChunk * Chunks), PatCopy)
                else PatBlt(Dc, ColorChunk * Chunks, 0, Width - (ColorChunk * Chunks), Height, PatCopy);
    DeleteObject(SelectObject(Dc,OldBrush));
    end;
  OffsetViewportOrgEx(Dc, Pt.x, Pt.y, pt);
end;

function ColorAtRainbowPoint(ColorPlace : integer; RainbowWidth : integer; WrapToRed : bool) : TColorRef;
var
  ColorChunk : integer;
  ColorChunkIndex : integer;
  ColorChunkStart : integer;
begin
  if ColorPlace = 0 then
    begin
    result := RGB(255, 0, 0);
    exit;
    end;
  if WrapToRed then ColorChunk := RainbowWidth div 6
                else ColorChunk := RainbowWidth div 5;
  ColorChunkStart := ColorPlace div ColorChunk;
  ColorChunkIndex := ColorPlace mod ColorChunk;
  case ColorChunkStart of
    0 : result := RGB(255, (255 div ColorChunk) * ColorChunkIndex, 0);
    1 : result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex, 255, 0);
    2 : result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex);
    3 : result := RGB(0, 255 - (255 div ColorChunk) * ColorChunkIndex, 255);
    4 : result := RGB((255 div ColorChunk) * ColorChunkIndex, 0, 255);
    5 : result := RGB(255, 0, 255 - (255 div ColorChunk) * ColorChunkIndex);
  else
    if WrapToRed then result := RGB(255, 0, 0)
                else result := RGB(255, 0, 255);
  end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  PaintRainbow(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, false, true);
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  InvalidateRect(Form1.Handle, nil, false);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  Color : TColorRef;
begin
  Color := ColorAtRainbowPoint(y, Form1.ClientWidth, true);
  ShowMessage(IntToStr(GetRValue(Color)) + #32 + IntToStr(GetGValue(Color)) + #32 +  IntToStr(GetBValue(Color)));
end;

K čemu dnešní příklad použijete, to již ponechám jako obvykle na vás. Zřejmě asi nebude nejvhodnější dávat takové barevné pozadí na hlavní formulář aplikace, ale jistě se najdou i jiná vhodná místa. Rovněž si povšimněte, že není nutné aplikovat kreslení spektra pouze na pozadí formuláře, ale prakticky na libovolný objekt, která má "plátno" (Canvas). Například jej můžete použít jako pozadí ToolBaru, ale musíte si dát v tomto případě pozor na překreslování jednotlivých prvků (tlačítek), které bude ToolBar obsahovat.

A to je již pro dnešek opravdu vše a jako obvykle vás v podobných případech vybízím k experimentování se zdrojákem. Určitě se vám povede vykouzlit různé barevné "šílenosti".