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

Tipy a triky v Delphi, díl 36. - Převrácení obrázku po vertikální nebo horizontální ose; Rotace obrázku; Tónování barev obrázku; Převod barev do odstínů šedi; Transparentní text v obrázku

Jan Šindelář - 3.4.2002

Převrácení obrázku po vertikální nebo horizontální ose

Jedna z nejběžnějších funkcí grafických prohlížečů nebo editorů. Zadaný obrázek (v našem případě bitmapa) se dle volby uživatele překlopí podél pomyslné vertikální či horizontální osy. Způsobů, jak toho docílit, existuje více a my si jeden z nich ukážeme.

Na formulář si připravte OpenPictureDialog a taktéž komponentu Image, do které bude obrázek načten a v níž bude také převracen. Funkce překlopení (zrcadlení) po vertikální a horizontální ose jsou jako obvykle definovány jako události dvou tlačítek.

.
.
.
type
  EBitmapError = Class(Exception);
  TRGBArray = array[0..0] of TRGBTriple;
  pRGBArray = ^TRGBArray;
.
.
.

procedure MirrorVertical(Bitmap: TBitmap);
var
i, j, w : integer;
RowIn : pRGBArray;
RowOut : pRGBArray;
begin
w := Bitmap.Width * SizeOf(TRGBTriple);
GetMem(RowIn, w);
for j := 0 to Bitmap.Height - 1 do
begin
  Move(Bitmap.ScanLine[j]^, RowIn^, w);
  RowOut := Bitmap.ScanLine[j];
  for i := 0 to Bitmap.Width -1 do RowOut[i] := RowIn[Bitmap.Width -1 - i];
end;
Bitmap.Assign(Bitmap);
FreeMem(RowIn);
end;

procedure MirrorHorizontal(Bitmap: TBitmap);
var
j, w :integer;
Tmp :Tbitmap;
begin
Tmp := TBitmap.Create;
Tmp.Width := Bitmap.Width;
Tmp.Height := Bitmap.Height;
Tmp.PixelFormat := Bitmap.PixelFormat;
w := Bitmap.Width * SizeOf(TRGBTriple);
for j := 0 to Bitmap.Height - 1 do Move(Bitmap.ScanLine[j]^, Tmp.ScanLine[Bitmap.Height -1 -j]^, w);
Bitmap.Assign(Tmp);
Tmp.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenPictureDialog1.Execute then Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if Image1.Picture <> nil then MirrorHorizontal(Image1.Picture.Bitmap);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
if Image1.Picture <> nil then MirrorVertical(Image1.Picture.Bitmap);
end;

Jak vidíte, veškeré operace probíhají "pouze" v paměti, v rámci komponenty Image, takže nedojde k přepsání původního souboru. Budete-li chtít však takto nově upravený obrázek uložit (vytvořit nový soubor či přepsat ten původní), není to sebemenší problém pomocí procedury Picture.SaveToFile komponenty Image. Toto bude ostatně platit i o všech dalších dnešních příkladech.

Rotace obrázku

I následující funkce patří mezi skupinu těch, které patří mezi nejzákladnější při práci s obrázky. Ukážeme si, jak rotovat obrázek o 90 stupňů. V podstatě by se dalo funkce použít i na rotaci o 180 či 270 stupňů jejím opakovaným použitím, i když by to bylo poněkud těžkopádné řešení.

.
.
.
type
THelpRGB = packed record
              rgb: TRGBTriple;
              dummy: byte;
            end;
TRGBArray = array[0..0] of TRGBTriple;
pRGBArray = ^TRGBArray;
.
.
.

procedure Rotace90(Bitmap: TBitmap);
var
aStream: TMemorystream;
header: TBITMAPINFO;
dc: hDC;
P: ^THelpRGB;
x, y, b, h: Integer;
RowOut: pRGBArray;
begin
aStream := TMemorystream.Create;
aStream.SetSize(Bitmap.Height * Bitmap.Width * 4);
with header.bmiHeader do
begin
  biSize := SizeOf(TBITMAPINFOHEADER);
  biWidth := Bitmap.Width;
  biHeight := Bitmap.Height;
  biPlanes := 1;
  biBitCount := 32;
  biCompression := 0;
  biSizeImage := aStream.Size;
  biXPelsPerMeter := 1;
  biYPelsPerMeter := 1;
  biClrUsed := 0;
  biClrImportant := 0;
end;
dc := GetDC(0);
P := aStream.Memory;
GetDIBits(dc, Bitmap.Handle, 0, Bitmap.Height, P, Header, dib_RGB_Colors);
ReleaseDC(0, dc);
b := Bitmap.Height;
h := Bitmap.Width;
Bitmap.Width := b;
Bitmap.Height := h;
for y := 0 to (h-1) do
begin
  rowOut := Bitmap.ScanLine[y];
  P := aStream.Memory;
  Inc(p, y);
  for x := 0 to (b-1) do
  begin
    RowOut[x] := p^.rgb;
    Inc(p,h);
  end;
end;
aStream.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenPictureDialog1.Execute then Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if Image1.Picture <> nil then Rotace90(Image1.Picture.Bitmap);
end;

Tónování barev obrázku

Dalo by se říci, že tato funkce patří již do kategorie efektů, i když je to jen velmi jednoduchý efekt. Jedná se – zjednodušeně řečeno – o to, že barvy obrázku budou tónovány uživatelem definovanou barvou, takže získají určitý barevný nádech. Je to stejné, jako bychom se na obrázek dívali přes průhlednou fólii dané barvy.

procedure Tonovani(aSource, aTarget: TBitmap; AColor: TColor);
var
i, j: integer;
s, t: pRGBTriple;
r, g, b: byte;
cl: Tcolor;
begin
cl := ColorToRGB(aColor);
r := GetRValue(cl);
g := GetGValue(cl);
b := GetBValue(cl);
ASource.PixelFormat := pf24bit;
ATarget.PixelFormat := pf24bit;
ATarget.Width := aSource.Width;
ATarget.Height := aSource.Height;
for i:= 0 to aSource.Height - 1 do
begin
  s := aSource.ScanLine[i];
  t := aTarget.ScanLine[i];
  for j := 0 to aSource.Width - 1 do
  begin
    t^.rgbtRed := (r * s^.rgbtRed) div 255;
    t^.rgbtGreen := (g * s^.rgbtGreen) div 255;
    t^.rgbtBlue := (b * s^.rgbtBlue) div 255;
    inc(s);
    inc(t);
  end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if Image1.Picture <> nil then
if ColorDialog1.Execute then Tonovani(Image1.Picture.Bitmap, Image1.Picture.Bitmap, ColorDialog1.Color);
Image1.Repaint;
end;

Funkce je opět volána jako událost tlačítka. Jak vidíte, parametry umožňují pracovat zvlášť se zdrojovým a cílovým obrázkem, takže pokud chcete vidět hezky vedle sebe původní a nový obrázek, stačí si přidat na formulář druhou komponentu Image a upravit parametry volané funkce. V tom případě také můžete smazat volání Repaint zdrojového obrázku, protože již nebude třeba.

Převod barev do odstínů šedi

Převod barev obrázku do odstínů šedi je další z obvyklých funkcí a řekl bych, že docela potřebnou, protože řada fotografií získá převodem na "černobílou" zcela jiný umělecký rozměr. Ale to teď nechme stranou, ukažme si rovnou samotnou funkci na převod. Podobně jako u předchozích funkcí lze i tuto provést řadou způsobů, z nichž jeden vám předkládám:

procedure Grayscale(const Bmp: TBitmap);
type
  TRGBArray = array[0..32767] of TRGBTriple;
  pRGBArray = ^TRGBArray;
var
  x, y, Gray: Integer;
  Row: pRGBArray;
begin
  Bmp.PixelFormat := pf24Bit;
  for y := 0 to Bmp.Height - 1 do
  begin
    Row := Bmp.ScanLine[y];
    for x := 0 to Bmp.Width - 1 do
    begin
      Gray := (Row[x].rgbtRed + Row[x].rgbtGreen + Row[x].rgbtBlue) div 3;
      Row[x].rgbtRed := Gray;
      Row[x].rgbtGreen := Gray;
      Row[x].rgbtBlue := Gray;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if Image1.Picture <> nil then Grayscale(Image1.Picture.Bitmap);
Form1.Image1.Repaint;
end;

Opět, stejně jako u všech předchozích příkladů, je třeba mít na formuláři komponentu Image, do které například pomocí OpenPictureDialogu nejprve načteme bitmapu.

Transparentní text v obrázku

Velmi užitečnou funkcí též může být umístění transparentního textu, tedy textu s průhledným pozadím, přímo do obrázku. Jaký může být způsob využití takové funkce? Namátkou mě napadá třeba situace, kdy potřebujete hromadně u desítek obrázků přidat do jejich rohu váš copyright nebo časový údaj pro budoucí prezentaci. V tom případě vám může tato funkce ušetřit řadu času.

Příklad opět předpokládá, že v komponentě Image máte již načtenu bitmapu, a samotné přidání textu bude opět voláno jako událost stisku tlačítka:

procedure TForm1.Button1Click(Sender: TObject);
begin
  with Image1.Picture.Bitmap.Canvas do
  begin
    Font.Color  := clRed;
    Brush.Style := bsclear;
    Font.Size  := 13;
    TextOut(10, 10, `Dnes je 3.4. 2002`);
  end;
end;

Jak vidíte, lze bez problému měnit všechny základní parametry textu. Pokud by vám snad nevyhovovalo, že je text transparentní, stačí příslušným způsobem změnit Brush.Style například na bsSolid a v tom případě bude pod textem pozadí.

A to je pro dnešek všechno. Příště si ještě ukážeme několik drobných funkcí s obrázky a začneme se opět věnovat jiným tématům.