Создание градиентной заливки

Delphi , Графика и Игры , Canvas

Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

procedure FillGradientRect(Canvas: TCanvas; Recty: TRect; fbcolor, fecolor: TColor; fcolors: Integer);
 var
   i, j, h, w, fcolor: Integer;
   R, G, B: Longword;
   beginRGBvalue, RGBdifference: array[0..2] of Longword;
 begin
   beginRGBvalue[0] := GetRvalue(colortoRGB(FBcolor));
   beginRGBvalue[1] := GetGvalue(colortoRGB(FBcolor));
   beginRGBvalue[2] := GetBvalue(colortoRGB(FBcolor));

   RGBdifference[0] := GetRvalue(colortoRGB(FEcolor)) - beginRGBvalue[0];
   RGBdifference[1] := GetGvalue(colortoRGB(FEcolor)) - beginRGBvalue[1];
   RGBdifference[2] := GetBvalue(colortoRGB(FEcolor)) - beginRGBvalue[2];

   Canvas.pen.Style := pssolid;
   Canvas.pen.mode := pmcopy;
   j := 0;
   h := recty.Bottom - recty.Top;
   w := recty.Right - recty.Left;

   for i := fcolors downto 0 do
   begin
     recty.Left  := muldiv(i - 1, w, fcolors);
     recty.Right := muldiv(i, w, fcolors);
     if fcolors1 then
     begin
       R := beginRGBvalue[0] + muldiv(j, RGBDifference[0], fcolors);
       G := beginRGBvalue[1] + muldiv(j, RGBDifference[1], fcolors);
       B := beginRGBvalue[2] + muldiv(j, RGBDifference[2], fcolors);
     end;
     Canvas.Brush.Color := RGB(R, G, B);
     patBlt(Canvas.Handle, recty.Left, recty.Top, Recty.Right - recty.Left, h, patcopy);
     Inc(j);
   end;
 end;

 // Case 1 

procedure TForm1.FormPaint(Sender: TObject);
 begin
   FillGradientRect(Form1.Canvas, rect(0, 0, Width, Height), $FF0000, $00000, $00FF);
 end;


 // Case 2 
procedure TForm1.FormPaint(Sender: TObject);
 var
   Row, Ht: Word;
   IX: Integer;
 begin
   iX := 200;
   Ht := (ClientHeight + 512) div 256;
   for Row := 0 to 512 do
   begin
     with Canvas do
     begin
       Brush.Color := RGB(Ix, 0, row);
       FillRect(Rect(0, Row * Ht, ClientWidth, (Row + 1) * Ht));
       IX := (IX - 1);
     end;
   end;
 end;


 { 
  Note, that the OnResize event should also call the FormPaint 
  method if this form is allowed to be resizable. 
  This is because if it is not called then when the 
  window is resized the gradient will not match the rest of the form. 
}

 {***********************************************************}

 {2. Another function}


 procedure TForm1.Gradient(Col1, Col2: TColor; Bmp: TBitmap);
 type
   PixArray = array [1..3] of Byte;
 var
   i, big, rdiv, gdiv, bdiv, h, w: Integer;
   ts: TStringList;
   p: ^PixArray;
 begin
   rdiv := GetRValue(Col1) - GetRValue(Col2);
   gdiv := GetgValue(Col1) - GetgValue(Col2);
   bdiv := GetbValue(Col1) - GetbValue(Col2);

   bmp.PixelFormat := pf24Bit;

   for h := 0 to bmp.Height - 1 do
   begin
     p := bmp.ScanLine[h];
     for w := 0 to bmp.Width - 1 do
     begin
       p^[1] := GetBvalue(Col1) - Round((w / bmp.Width) * bdiv);
       p^[2] := GetGvalue(Col1) - Round((w / bmp.Width) * gdiv);
       p^[3] := GetRvalue(Col1) - Round((w / bmp.Width) * rdiv);
       Inc(p);
     end;
   end;
 end;

 procedure TForm1.Button1Click(Sender: TObject);
 var
   BitMap1: TBitMap;
 begin
   BitMap1 := TBitMap.Create;
   try
     Bitmap1.Width := 300;
     bitmap1.Height := 100;
     Gradient(clred, clBlack, bitmap1);
     // So konnte man das Bild dann zB in einem TImage anzeigen 
    // To show the image in a TImage: 
    Image1.Picture.Bitmap.Assign(bitmap1);
   finally
     Bitmap1.Free;
   end;
 end;

Статья Создание градиентной заливки раздела Графика и Игры Canvas может быть полезна для разработчиков на Delphi и FreePascal.

Комментарии и вопросы

:: Главная :: Canvas ::