// Verschiedene Farbverläufe.

// Getestet mit D4 unter XP

// 1. Variante:
Sehr simple Methode um den Verlauf einer Farbe hin zu
// Schwarz auf einer Zeichenfläche
(TCanvas) zu realisieren.

procedure verlauf(cnv: TCanvas; Rot, Gruen, Blau, vertikal, dunkler: boolean); 
var 
  stufe, faktor, farbe, richtung: integer; 
begin 
  if not Rot and not Gruen and not Blau then begin 
    Rot := true; 
    Gruen := Rot; 
    Blau := Rot; 
  end; 
  with cnv, cnv.cliprect do begin 
    if vertikal then richtung := (bottom - top) else richtung := (right - left); 
    faktor := succ(richtung div 256); 
    for stufe := 0 to 255 do begin 
      farbe := abs(ord(dunkler) * 255 - stufe); 
      Brush.Color := RGB(ord(Rot) * farbe, ord(Gruen) * farbe, ord(blau) * farbe); 
      if vertikal then 
        FillRect(Rect(0, stufe * faktor, right, succ(stufe) * faktor)) 
      else FillRect(Rect(stufe * faktor, 0, succ(stufe) * faktor, bottom)); 
    end; 
  end; 
end; 

// ------------------ Beispiel --------------

// Die Fläche einer Paintbox erhält einen Farbverlauf.

procedure TForm1.FormPaint(Sender: TObject); 
begin 
  verlauf(paintbox1.canvas, true,  false, true,  false, true); // violett 
(*                        , true,  false, false,               // rot 
                          , true,  true,  false,               // gelb 
                          , false, false, true,                // blau 
                          , false, true,  false,               // grün 
                          , false, true,  true,                // blaugrün 
                          , false, false, false,               // grau 
                          , true,  true,  true,                // grau *) 
end;

// ----------------------------------------------------------------------


//
2. Variante: Es
können zwei Farben und ein Rechteck definiert werden.

procedure DrawGradient(const Canvas: TCanvas; C1, C2: TColor; 
  X1, Y1, X2, Y2: Integer; Horizontal: Boolean); 
var 
  Y, R, G, B, H, DR, DB, DG: Integer; 
  RC1, GC1, BC1: Integer; 
  RC2, GC2, BC2: Integer; 
begin 
  if Y1 > Y2 then begin 
    Y := Y1; 
    Y1 := Y2; 
    Y2 := Y; 
  end; 
  if X1 > X2 then begin 
    Y := X1; 
    X1 := X2; 
    X2 := Y; 
  end; 
  C1 := ColorToRGB(C1); 
  C2 := ColorToRGB(C2); 
  RC1 := GetRValue(C1); 
  GC1 := GetGValue(C1); 
  BC1 := GetBValue(C1); 
  RC2 := GetRValue(C2); 
  GC2 := GetGValue(C2); 
  BC2 := GetBValue(C2); 
  DR := RC2 - RC1; 
  DG := GC2 - GC1; 
  DB := BC2 - BC1; 
  if Horizontal then begin 
    H := pred(X2 - X1); 
    for y := 0 to H do 
    begin 
      R := Round(RC1 + (DR * Y / H)); 
      G := Round(GC1 + (DG * Y / H)); 
      B := Round(BC1 + (DB * Y / H)); 
      Canvas.Brush.Color := RGB(R, G, B); 
      Canvas.FillRect(Rect(X1 + Y, Y1, X1 + succ(Y), Y2)); 
    end; 
  end else begin 
    H := pred(Y2 - Y1); 
    for y := 0 to H do 
    begin 
      R := Round(RC1 + (DR * Y / H)); 
      G := Round(GC1 + (DG * Y / H)); 
      B := Round(BC1 + (DB * Y / H)); 
      Canvas.Brush.Color := RGB(R, G, B); 
      Canvas.FillRect(Rect(X1, Y1 + Y, X2, Y1 + succ(Y))); 
    end; 
  end; 
end;

// ------------------ Beispiel --------------

// Die Fläche einer Form erhält zwei Farbverläufe.

procedure zeichnen; 
begin 
  with Form2 do begin 
    DrawGradient(canvas, clLime, clRed, 0, 0, 
      clientwidth div 2, clientheight, true); 
    DrawGradient(canvas, clLime, clRed, clientwidth div 2, 
      0, clientwidth, clientheight, false); 
  end; 
end; 
 
procedure TForm2.FormPaint(Sender: TObject); 
begin 
  zeichnen; 
end; 
 
procedure TForm2.FormResize(Sender: TObject); 
begin 
  zeichnen; 
end;


// --------------------------------------------------------------------


//
3. Variante: Es werden Linien auf eine Zeichenfläche gezeichnet.
// Man kann Farbverläufe innerhalb eines Rechtecks mit mehreren Farben
// horizontal oder vertikal erstellen.

type 
  rgbarray = array[0..2] of byte; 
 
procedure 
  Farbverlauf(cv: TCanvas; Rect: TRect; horizontal: boolean; c: array of 
    TColor); 
var 
  x, y, z, stelle, mx, bis, fach, mass: integer; 
  faktor: double; 
  a: rgbarray; 
  b: array of rgbarray; 
  merkw: integer; 
  merks: TPenStyle; 
  merkp: TColor; 
begin 
  mx := high(c); 
  if mx > 0 then begin 
    if horizontal then mass := rect.right - rect.left 
    else mass := rect.bottom - rect.top; 
    setlength(b, mx + 1); 
    for x := 0 to mx do begin 
      c[x] := colortorgb(c[x]); 
      b[x][0] := getrvalue(c[x]); 
      b[x][1] := getgvalue(c[x]); 
      b[x][2] := getbvalue(c[x]); 
    end; 
    merkw := cv.Pen.Width; 
    merks := cv.Pen.Style; 
    merkp := cv.Pen.Color; 
    cv.Pen.Width := 1; 
    cv.Pen.Style := psSolid; 
    fach := round(mass / mx); 
    for y := 0 to mx - 1 do begin 
      if y = mx - 1 then bis := mass - y * fach - 1 
      else bis := fach; 
      for x := 0 to bis do begin 
        stelle := x + y * fach; 
        if bis = 0 then faktor := 1 else 
          faktor := x / bis; 
        for z := 0 to 2 do 
          a[z] := trunc(b[y][z] + ((b[y + 1][z] - b[y][z]) * faktor)); 
        cv.Pen.Color := RGB(a[0], a[1], a[2]); 
        if horizontal then begin 
          cv.MoveTo(rect.left + stelle, Rect.Top); 
          cv.LineTo(rect.left + stelle, Rect.Bottom); 
        end else begin 
          cv.MoveTo(rect.left, rect.top + stelle); 
          cv.LineTo(rect.right, rect.top + stelle); 
        end; 
      end; 
    end; 
    b := nil; 
    cv.Pen.Width := merkw; 
    cv.Pen.Style := merks; 
    cv.Pen.Color := merkp; 
  end 
  else showmessage('Es müssen mindestens 2 Farben angegeben werden'); 
end; 


// ------------------ Beispiel --------------

// ein Rechteck wird von links nach rechts mit 6 Farben gefüllt

procedure TForm1.Button3Click(Sender: TObject); 
var links, oben, rechts, unten: integer; 
begin 
  links := 10; 
  oben := 10; 
  rechts := 160; 
  unten := 100; 
  canvas.pen.color := clblack; 
  canvas.brush.style := bsclear; 
  canvas.rectangle(links, oben, rechts, unten); 
  farbverlauf(canvas, rect(links + 1, oben + 1, rechts - 1, unten - 1), true, 
    [clred, clwhite, clblack, clyellow, clgreen, claqua]); 
end; 

// ---------------------------------------------------------------------------


// 4. Variante: Um mehrere Verläufe zu benutzen und möglichst Flackern
// zu vermeiden, wird ein Bitmap zu Hilfe genommen. An dessen oberen Rand
// verlaufen andere Farben als am unteren Rand und auch von oben nach unten
// wird ein einfacher Verlauf realisiert.

type 
  rgbarray = array[0..2] of byte; 
  argbarray = array of rgbarray; 
 
var bmp: TBitmap; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bmp := TBitmap.create; 
  bmp.pixelformat := pf24bit; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bmp.free; 
end; 
 
procedure farbverlauf 
  (dc: HDC; x, y, breit, hoch: integer; oben, unten: array of TColor); 
var 
  b1, b2: rgbarray; 
  o, u, w, h, j, c, z, fo: integer; 
  ao: argbarray; 
  au: argbarray; 
  p: PBytearray; 
  procedure rgbermitteln(at: array of TColor; ar: argbarray; k: integer); 
  var i: integer; 
  begin 
    for i := 0 to k do begin 
      at[i] := colortorgb(at[i]); 
      ar[i][2] := getrvalue(at[i]); 
      ar[i][1] := getgvalue(at[i]); 
      ar[i][0] := getbvalue(at[i]); 
    end; 
  end; 
  function rechnen(ar: argbarray): byte; 
  begin 
    result := trunc(ar[j][z] + (ar[j + 1][z] - ar[j][z]) * (w / fo)); 
  end; 
begin 
  o := high(oben); 
  u := high(unten); 
  if o = u then begin 
    if o > 0 then begin 
      bmp.width := breit; 
      bmp.height := hoch; 
      setlength(ao, o + 1); 
      setlength(au, u + 1); 
      rgbermitteln(oben, ao, o); 
      rgbermitteln(unten, au, u); 
      fo := trunc(breit / o + 1) * 3; 
      for h := 0 to hoch - 1 do begin 
        p := bmp.scanline[h]; 
        for j := 0 to o do begin 
          w := 0; 
          while w <= fo - 1 do begin 
            c := j * fo + w; 
            if c <= breit * 3 - 1 then begin 
              for z := 0 to 2 do begin 
                b1[z] := rechnen(ao); 
                b2[z] := rechnen(au); 
                p[c + z] := trunc(b1[z] + (b2[z] - b1[z]) * (h / hoch)); 
              end; 
            end; 
            inc(w, 3); 
          end; 
        end; 
      end; 
      bitblt(dc, x, y, breit, hoch, bmp.canvas.handle, 0, 0, srccopy); 
    end else showmessage('Es müssen mindestens zwei Farben angegeben werden!'); 
  end else 
    showmessage('Die Anzahl der Farben muss oben und unten gleich sein!'); 
end; 


// ------------------ Beispiel --------------

// Ein Rechteck von 120 Pixel Breite und 120 Pixel Höhe wird mit
// einem Mehrfach-Farbverlauf gefüllt

procedure TForm1.Button3Click(Sender: TObject); 
begin 
  farbverlauf(canvas.handle, 20, 30, 120, 120, 
    [clblack, claqua, clblack, clfuchsia, clblack, clyellow, clblack], 
    [clblack, clyellow, clblack, cllime, clblack, clred, clblack]); 
end; 


// -------------------------------------------------------------------------


// 5. Variante: Wer nur einen einfachen Verlauf zwischen zwei Farben benötigt,
// kann den folgenden Code verwenden, welcher die Farben mittels API-Aufruf
// einem Bitmap zuweist. Zusätzlich zu den vier Verlaufsrichtungen kann die
// Dominanz der zuerst benannten Farbe gesteuert werden, wodurch unterschiedlich
// starke Verläufe realisiert werden.

type 
  Richtung = (VonLinksNachRechts, VonRechtsNachLinks, 
    VonObenNachUnten, VonUntenNachOben); 
 
procedure verlaufx(bm: TBitmap; wdth, hght: integer; 
  Start, Ende: TColor; Dominanz: Single; wie: Richtung); 
var 
  tb: tagBITMAP; 
  i, j: integer; 
  s: Single; 
  CStep, TmpC: array[0..2] of Single; 
  ColorS, ColorE: array[0..2] of byte; 
  BmBitsx: array of array[0..3] of byte; 
  function CalcStep(von, bis: integer): Single; 
  begin 
    if von > bis then begin 
      Result := von - bis; 
      if Result <> 0 then 
        Result := -(Result / (wdth * Dominanz)) 
    end else begin 
      Result := bis - von; 
      if Result <> 0 then 
        Result := Result / (wdth * Dominanz); 
    end; 
  end; 
  procedure quad(wh: integer); 
  begin 
    BmBitsx[i + j * wh][3] := 0; 
    BmBitsx[i + j * wh][2] := trunc(TmpC[0]); 
    BmBitsx[i + j * wh][1] := trunc(TmpC[1]); 
    BmBitsx[i + j * wh][0] := trunc(TmpC[2]); 
  end; 
  procedure steps; 
  var x: integer; 
  begin 
    for x := 0 to 2 do 
      TmpC[x] := TmpC[x] + CStep[x]; 
  end; 
begin 
  if (wdth < 2) or (hght < 2) then raise exception.create('Bitmap-Abmaße zu niedrig'); 
  if ord(wie) < 2 then s := wdth / 10 else s := hght / 10; 
  if (dominanz < 1) or (dominanz > s) then
    raise exception.create('Dominanz überschreitet Toleranzgrenze'); 
  Start := ColorToRGB(Start); 
  Ende := ColorToRGB(Ende); 
  CopyMemory(@ColorS, @Start, 3); 
  CopyMemory(@ColorE, @Ende, 3); 
  for i := 0 to 2 do begin 
    CStep[i] := CalcStep(ColorS[i], ColorE[i]); 
    TmpC[i] := ColorS[i]; 
  end; 
  setlength(BmBitsx, wdth * hght); 
  case wie of 
    VonLinksNachRechts: begin 
        for i := 0 to wdth - 1 do begin 
          steps; 
          for j := 0 to hght - 1 do 
            quad(wdth); 
        end; 
      end; 
    VonUntenNachOben: begin 
        for j := wdth - 1 downto 0 do begin 
          steps; 
          for i := 0 to hght - 1 do 
            quad(hght); 
        end; 
      end; 
    VonObenNachUnten: begin 
        for j := 0 to wdth - 1 do begin 
          steps; 
          for i := 0 to hght - 1 do 
            quad(hght); 
        end; 
      end; 
  else begin 
      for i := wdth - 1 downto 0 do begin 
        steps; 
        for j := 0 to hght - 1 do 
          quad(wdth); 
      end; 
    end; 
  end; 
  with tb do begin 
    bmtype := 0; 
    bmwidth := wdth; 
    bmheight := hght; 
    bmwidthbytes := wdth * 4; 
    bmplanes := 1; 
    bmbitspixel := 32; 
    bmbits := bmbitsx; 
  end; 
  bm.handle := CreateBitmapIndirect(tb); 
  BmBitsx := nil; 
end; 

// ------------------ Beispiel --------------

// Zwei Farbverläufe mit unterschiedlicher Dominanz der Farbe Gelb:

procedure TForm1.Button3Click(Sender: TObject); 
var Bitmap: TBitmap; 
begin 
  Bitmap := TBitmap.create; 
  verlaufx(Bitmap, 80, 40, clyellow, clblue, 1, VonLinksNachRechts); 
  canvas.draw(310, 10, Bitmap); 
  verlaufx(Bitmap, 80, 40, clyellow, clblue, 1.4, VonLinksNachRechts); 
  canvas.draw(310, 55, Bitmap); 
  Bitmap.free; 
end;

// ---------------------------------------------------------------------------


// 6. Variante: Ein Farbverlauf unter Zuhilfenahme des "GDI".

type 
  TForm1 = class(TForm) 
    procedure FormPaint(Sender: TObject); 
    procedure FormResize(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen }
  end; 
 
var 
  Form1: TForm1; 
  function GradientFill(hdc: HDC; pVertex: PTriVertex;
   dwNumVertex: DWORD; pMesh: Pointer; 
   dwNumMesh: DWORD; dwMode: DWORD): Boolean; stdcall;
   external 'gdi32.dll' name 'GdiGradientFill'; 
 
implementation 
 
{$R *.DFM} 
 
procedure RechteckVerlauf(DC: HDC; x1, y1, x2, y2: integer; von, nach: TColor; 
  horizontal: boolean); 
type 
  TVertex = packed record 
    x, y: Integer; 
    rot, gruen, blau, Alpha: Word; 
  end; 
const 
  VertexCount = 2; 
var 
  Vertex: array[0..VertexCount - 1] of TVertex; 
  TVRect: TGradientRect; 
  richtung: Cardinal; 
begin 
  von := ColorToRGB(von); 
  nach := ColorToRGB(nach); 
  if horizontal then richtung := GRADIENT_FILL_RECT_H 
  else richtung := GRADIENT_FILL_RECT_V; 
  Vertex[0].x := x1; 
  Vertex[0].y := y1; 
  Vertex[0].rot := getrvalue(von) shl 8; 
  Vertex[0].gruen := getgvalue(von) shl 8; 
  Vertex[0].blau := getbvalue(von) shl 8; 
  Vertex[0].Alpha := 0; 
  Vertex[1].x := x2; 
  Vertex[1].y := y2; 
  Vertex[1].rot := getrvalue(nach) shl 8; 
  Vertex[1].gruen := getgvalue(nach) shl 8; 
  Vertex[1].blau := getbvalue(nach) shl 8; 
  Vertex[1].Alpha := 0; 
  with TVREct do begin 
    UpperLeft := 0; 
    LowerRight := 1; 
  end; 
  GradientFill(DC, @Vertex[0], VertexCount, @TVREct, 1, richtung); 
end; 

// ------------------ Beispiel --------------


 

procedure TForm1.FormPaint(Sender: TObject); 
begin 
  RechteckVerlauf(canvas.handle, 0, 0, clientwidth, clientheight, 
    $88FF, clblue, true); 
end; 

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

// -------------------------------------------------------------------------


// 7. Variante: Ein dreifach Farbverlauf in einem Dreieck mittels "GDI".

type 
  TForm1 = class(TForm) 
    procedure FormPaint(Sender: TObject); 
    procedure FormResize(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen }
  end; 
 
var 
  Form1: TForm1; 
  function GradientFill(hdc: HDC; pVertex: PTriVertex; 
   dwNumVertex: DWORD; pMesh: Pointer; 
   dwNumMesh: DWORD; dwMode: DWORD): Boolean; stdcall; 
   external 'gdi32.dll' name 'GdiGradientFill';

implementation 
 
{$R *.DFM} 
 
procedure DreieckVerlauf(DC: HDC; x1, y1, x2, y2, x3, y3: integer; 
  eins, zwei, drei: TColor); 
type 
  TVertex = packed record 
    x, y: Integer; 
    rot, gruen, blau, Alpha: Word; 
  end; 
const 
  VertexCount = 3; 
var 
  Vertex: array[0..VertexCount - 1] of TVertex; 
  Triangle: TGradientTriangle; 
begin 
  eins := ColorToRGB(eins); 
  zwei := ColorToRGB(zwei); 
  drei := ColorToRGB(drei); 
  Vertex[0].x := x1; 
  Vertex[0].y := y1; 
  Vertex[0].rot := getrvalue(eins) shl 8; 
  Vertex[0].gruen := getgvalue(eins) shl 8; 
  Vertex[0].blau := getbvalue(eins) shl 8; 
  Vertex[0].Alpha := 0; 
  Vertex[1].x := x2; 
  Vertex[1].y := y2; 
  Vertex[1].rot := getrvalue(zwei) shl 8; 
  Vertex[1].gruen := getgvalue(zwei) shl 8; 
  Vertex[1].blau := getbvalue(zwei) shl 8; 
  Vertex[1].Alpha := 0; 
  Vertex[2].x := x3; 
  Vertex[2].y := y3; 
  Vertex[2].rot := getrvalue(drei) shl 8; 
  Vertex[2].gruen := getgvalue(drei) shl 8; 
  Vertex[2].blau := getbvalue(drei) shl 8; 
  Vertex[2].Alpha := 0; 
  Triangle.Vertex1 := 0; 
  Triangle.Vertex2 := 1; 
  Triangle.Vertex3 := 2; 
  GradientFill(DC, @Vertex[0], VertexCount, @TRiangle, 1, GRADIENT_FILL_TRIANGLE); 
end; 

// ------------------ Beispiel --------------

procedure TForm1.FormPaint(Sender: TObject); 
begin 
  DreieckVerlauf(canvas.handle, 0, 0, 0, clientheight, clientwidth, 
    clientheight div 2, clblue, cllime, clred); 
end; 
 
procedure TForm1.FormResize(Sender: TObject); 
begin 
  refresh; 
end; 


// ----------------------------------------------------------------------------

// 8. Variante: Der folgende Code erlaubt einen Farbverlauf bis 45 nach
// rechts oder links zu neigen. Es können bis zu 8 Farben verwendet werden.

procedure farbverlauf 
  (dc: HDC; x, y, breit, hoch: integer; ar: array of TColor; Winkel: Single); 
var 
  bmp: TBitmap; 
  o, w, h, j, c, z, v, br, fo: integer; 
  ao: array of array[0..2] of byte; 
  p: PBytearray; 
  procedure rgbermitteln; 
  var 
    i: integer; 
  begin 
    for i := 0 to o do begin 
      ar[i] := colortorgb(ar[i]); 
      ao[i][2] := getrvalue(ar[i]); 
      ao[i][1] := getgvalue(ar[i]); 
      ao[i][0] := getbvalue(ar[i]); 
    end; 
    for i := 0 to 2 do 
      ao[o + 1][i] := ao[0][i]; 
  end; 
  function rechnen: byte; 
  begin 
    result := trunc(ao[j][z] + (ao[j + 1][z] - ao[j][z]) * (w / fo)); 
  end; 
begin 
  if (breit > 1) and (hoch > 1) then begin 
    if (Winkel >= -45) and (Winkel <= 45) then begin 
      o := high(ar); 
      if (o > 0) and (o < 8) then begin 
        bmp := TBitmap.create; 
        bmp.pixelformat := pf24bit; 
        Winkel := -Winkel / 45; 
        fo := round(breit / o + 1.3333) * 3; 
        bmp.width := breit; 
        bmp.height := hoch; 
        br := breit * 3; 
        setlength(ao, o + 2); 
        rgbermitteln; 
        for h := 0 to hoch - 1 do begin 
          p := bmp.scanline[h]; 
          for j := 0 to o do begin 
            w := 0; 
            while w < fo do begin 
              c := j * fo + w + round(h * Winkel) * 3; 
              v := br + fo + o * 3; 
              while c < 0 do inc(c, v); 
              while c >= v do dec(c, v); 
              if c < br then 
                for z := 0 to 2 do 
                  p[c + z] := rechnen; 
              inc(w, 3); 
            end; 
          end; 
        end; 
        bitblt(dc, x, y, breit, hoch, bmp.canvas.handle, 0, 0, srccopy); 
        bmp.free; 
      end else showmessage('Anzahl der Farben ungültig!'); 
    end else showmessage('Der Winkel muss zwischen -45.0 und +45.0 liegen!'); 
  end else showmessage('Abmaße zu gering!'); 
end; 


// ------------------ Beispiel --------------

procedure TForm1.Button2Click(Sender: TObject); 
begin 
  farbverlauf(canvas.handle, 10, 20, 75, 80, [$330000, $FFE080, 
    $330000, $FFE080], 33.3); 
end;


// ----------------------------------------------------------------------------


// 9. Variante: Zwei Farben verlaufen stufenweise.

procedure StufenVerlauf(cnv: TCanvas; F1, F2: TColor; stufen: byte; 
  X1, Y1, X2, Y2: integer; horizontal: boolean); 
var 
  r1, g1, b1: byte; 
  v, u, f, i, h: integer; 
  r, g, b, dr, dg, db: single; 
begin 
  if stufen < 2 then stufen := 2; 
  if Y1 > Y2 then begin 
    i := Y1; 
    Y1 := Y2; 
    Y2 := i; 
  end; 
  if X1 > X2 then begin 
    i := X1; 
    X1 := X2; 
    X2 := i; 
  end; 
  if horizontal then 
    h := X2 - X1 else 
    h := Y2 - Y1; 
  if stufen > h then stufen := h; 
  v := pred(stufen); 
  f := round(h / stufen); 
  F1 := ColorToRGB(F1); 
  F2 := ColorToRGB(F2); 
  r1 := getrvalue(F1); 
  g1 := getgvalue(F1); 
  b1 := getbvalue(F1); 
  dr := (getrvalue(F2) - r1) / v; 
  dg := (getgvalue(F2) - g1) / v; 
  db := (getbvalue(F2) - b1) / v; 
  for i := 0 to v do begin 
    with cnv do begin 
      r := r1 + i * dr; 
      g := g1 + i * dg; 
      b := b1 + i * db; 
      brush.color := RGB(round(r), round(g), round(b)); 
      if horizontal then begin 
        if i = v then u := X2 else 
          u := X1 + succ(i) * f; 
        fillrect(rect(X1 + i * f, Y1, u, Y2)); 
      end else begin 
        if i = v then u := Y2 else 
          u := Y1 + succ(i) * f; 
        fillrect(rect(X1, i * f + Y1, X2, u)); 
      end; 
    end; 
  end; 
end;


// ------------------ Beispiel --------------



 

procedure TForm1.Button2Click(Sender: TObject); 
begin 
  canvas.rectangle(29, 29, 101, 101); 
  stufenverlauf(canvas, clyellow, clpurple, 7, 30, 30, 100, 100, false); 
end;


// ----------------------------------------------------------------------------


// 10. Variante: Zwei Farben verlaufen stufenweise waagerecht als auch
// senkrecht. Dadurch ergibt sich ein mosaikartiger diagonaler Farbverlauf.
// Da der Aufbau langsam von statten geht, wird eine Bitmap eingesetzt.

procedure MosaikVerlauf(bm: TBitmap; F1, F2: TColor; 
  stufewaag, stufesenk: byte); 
var 
  r1, g1, b1: byte; 
  vh, vw, uh, uw, fh, fw, i, j: integer; 
  rj, gj, bj, ri, bi, gi, drh, dgh, dbh, drw, dgw, dbw: single; 
begin 
  if (bm.height > 1) and (bm.width > 1) then begin 
    if (stufesenk > bm.height) or (stufesenk < 2) then stufesenk := bm.height; 
    if (stufewaag > bm.width) or (stufewaag < 2) then stufewaag := bm.width; 
    vh := pred(stufesenk); 
    vw := pred(stufewaag); 
    fh := round(bm.height / stufesenk); 
    fw := round(bm.width / stufewaag); 
    F1 := ColorToRGB(F1); 
    F2 := ColorToRGB(F2); 
    r1 := getrvalue(F1); 
    g1 := getgvalue(F1); 
    b1 := getbvalue(F1); 
    drh := (getrvalue(F2) - r1) / vh; 
    dgh := (getgvalue(F2) - g1) / vh; 
    dbh := (getbvalue(F2) - b1) / vh; 
    drw := (getrvalue(F2) - r1) / vw; 
    dgw := (getgvalue(F2) - g1) / vw; 
    dbw := (getbvalue(F2) - b1) / vw; 
    for i := 0 to vw do begin 
      ri := r1 + i * drw; 
      gi := g1 + i * dgw; 
      bi := b1 + i * dbw; 
      if i = vw then uw := bm.width else 
        uw := succ(i) * fw; 
      for j := 0 to vh do begin 
        with bm.canvas do begin 
          rj := r1 + j * drh; 
          gj := g1 + j * dgh; 
          bj := b1 + j * dbh; 
          brush.color := RGB(round((rj + ri) / 2), round((gj + gi) / 2), 
            round((bj + bi) / 2)); 
          if j = vh then uh := bm.height else 
            uh := succ(j) * fh; 
          fillrect(rect(i * fw, j * fh, uw, uh)); 
        end; 
      end; 
    end; 
  end; 
end;

// ------------------ Beispiel --------------

procedure TForm1.Button2Click(Sender: TObject); 
var bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  bm.width := 70; 
  bm.height := 70; 
  mosaikverlauf(bm, cllime, clred, 5, 5); 
  canvas.draw(30, 30, bm); 
  bm.free; 
end;


// ----------------------------------------------------------------------------

// 11. Variante: (Gespiegelte Verläufe) Der Code erlaubt neben einem einfachen
// diagonalen Verlauf drei gespiegelte Verläufe: Dreieck, Diamant und Linse.

type 
  shp = (Diagonal, Dreieck, Diamant, Linse); 
 
procedure verlauf(bm: TBitmap; farbe1, farbe2: TColor; art: shp); 
var 
  x, y, h, w, w3: integer; 
  p: pBytearray; 
  ri, gi, bi: byte; 
  ra, ga, ba: word; 
  rd, gd, bd, a, d: single; 
begin 
  bm.pixelformat := pf24bit; 
  if art = Diamant then 
    h := bm.height shr 1 
  else h := bm.height - 1; 
  if art <> Diagonal then 
    w := bm.width shr 1 else 
    w := bm.width; 
  w3 := w * 3; 
  farbe1 := colortorgb(farbe1); 
  farbe2 := colortorgb(farbe2); 
  ra := getrvalue(farbe1); 
  ga := getgvalue(farbe1); 
  ba := getbvalue(farbe1); 
  ri := getrvalue(farbe2); 
  gi := getgvalue(farbe2); 
  bi := getbvalue(farbe2); 
  rd := ri - ra; 
  gd := gi - ga; 
  bd := bi - ba; 
  inc(ra, ra); 
  inc(ga, ga); 
  inc(ba, ba); 
  for y := 0 to h do begin 
    p := bm.scanline[y]; 
    a := y / h; 
    if art = Linse then a := sin(pi * a); 
    x := 0; 
    while x < w3 do begin 
      d := a + x / w3; 
      p[x] := trunc((ba + bd * d) / 2); 
      p[x + 1] := trunc((ga + gd * d) / 2); 
      p[x + 2] := trunc((ra + rd * d) / 2); 
      inc(x, 3); 
    end; 
  end; 
  if art <> Diagonal then 
    stretchblt(bm.canvas.handle, w, 0, w + 1, h + 1, 
      bm.canvas.handle, w - 1, 0, -w, h, SRCCOPY); 
  if art = Diamant then 
    stretchblt(bm.canvas.handle, 0, h + 1, bm.width, h, 
      bm.canvas.handle, 0, h, bm.width, -h, SRCCOPY); 
end;

// ------------------ Beispiel --------------
 
Dreiek Diamant Linse

procedure TForm1.Button2Click(Sender: TObject); 
var 
  bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  bm.width := 100; 
  bm.height := 75; 
  verlauf(bm, clblue, $80FF, Dreieck); 
  canvas.draw(10, 10, bm); 
  verlauf(bm, clblue, $80FF, Diamant); 
  canvas.draw(120, 10, bm); 
  verlauf(bm, clblue, $80FF, Linse); 
  canvas.draw(230, 10, bm); 
  bm.free; 
end;



// ----------------------------------------------------------------------------

// 12. Variante: Erstellen eines radialen Verlaufes. Wird eine Hintergrundfarbe
// angegeben, erzeugt das eine Ellipse. Ansonsten wird das komplette Rechteck
// ausgefüllt
.

procedure DrawR(bm: TBitmap; c1, c2: TColor; fw, fh: integer); 
var 
  i, stp: Integer; 
  R1, G1, B1, R2, G2, B2: Integer; 
  Rx, Gx, Bx: byte; 
begin 
  with bm, Canvas do begin 
    c1 := ColorToRGB(c1); 
    c2 := ColorToRGB(c2); 
    R1 := GetRValue(c1); 
    G1 := GetGValue(c1); 
    B1 := GetBValue(c1); 
    R2 := GetRValue(c2); 
    G2 := GetGValue(c2); 
    B2 := GetBValue(c2); 
    if width > height then 
      stp := height div 2 + fh else 
      stp := width div 2 + fw; 
    for i := 1 to stp do begin 
      Rx := Round(R1 - ((R1 - R2) / stp) * i); 
      Gx := Round(G1 - ((G1 - G2) / stp) * i); 
      Bx := Round(B1 - ((B1 - B2) / stp) * i); 
      Brush.Color := RGB(Rx, Gx, Bx); 
      Pen.Color := Brush.Color; 
      Ellipse(i - fw, i - fh, width - i + fw, height - i + fh); 
    end; 
  end; 
end; 
 
procedure DrawRadial(bm: TBitmap; c1, c2: TColor); overload; 
var dm: double; 
  fw, fh: integer; 
begin 
  with bm do begin 
    dm := sqrt(sqr(width) + sqr(height)); 
    fw := round((dm - width) / 2) + 2; 
    fh := round((dm - height) / 2) + 2; 
  end; 
  DrawR(bm, c1, c2, fw, fh); 
end; 
 
procedure DrawRadial(bm: TBitmap; c1, c2, Hintergrund: TColor); overload; 
begin 
  with bm.Canvas do begin 
    brush.color := Hintergrund; 
    fillrect(cliprect); 
  end; 
  DrawR(bm, c1, c2, 0, 0); 
end; 
 
// -------------------- Beispiel ------------------------ 

 
procedure TForm1.Button1Click(Sender: TObject); 
var bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  bm.width := 100; 
  bm.height := 100; 
  drawradial(bm, clblack, cllime, Color); 
  canvas.draw(500, 20, bm); 
  bm.width := 125; 
  bm.height := 75; 
  drawradial(bm, clblack, clRed, Color); 
  canvas.draw(602, 32, bm); 
  bm.width := 75; 
  bm.height := 125; 
  drawradial(bm, clblack, clYellow); 
  canvas.draw(730, 5, bm); 
  bm.free; 
end;
 

// ----------------------------------------------------------------------------

// 13. Variante: Verlauf Schwarz-Farbe-Schwarz

type 
  art = (vlHorizontal, vlVertical, vlRadial); 
 
procedure grad(bm: TBitmap; Farbe: TColor; wie: art); 
var x, y, z, x3: integer; 
  x1, x2, y1, y2, sx, sy: single; 
  r, g, b: byte; 
  p: pbytearray; 
begin 
  bm.pixelformat := pf24bit; 
  case wie of 
    vlHorizontal: begin 
        x2 := bm.height; 
        y2 := bm.height; 
      end; 
    vlVertical: begin 
        x2 := bm.width; 
        y2 := bm.width; 
      end; 
  else begin 
      x2 := bm.width; 
      y2 := bm.height; 
    end; 
  end; 
  Farbe := ColorToRGB(Farbe); 
  r := GetRValue(Farbe); 
  g := GetGValue(Farbe); 
  b := GetBValue(Farbe); 
  for y := 0 to bm.height - 1 do begin 
    p := bm.scanline[y]; 
    for x := 0 to bm.width - 1 do begin 
      x3 := x * 3; 
      case wie of 
        vlHorizontal: begin 
            x1 := y; 
            y1 := y; 
          end; 
        vlVertical: begin 
            x1 := x; 
            y1 := x; 
          end; 
      else begin 
          x1 := x; 
          y1 := y; 
        end; 
      end; 
      sx := sin(x1 / x2 * pi); 
      sy := sin(y1 / y2 * pi); 
      z := trunc(sx * sy * 256); 
      p[x3] := (z * b) shr 8; 
      p[x3 + 1] := (z * g) shr 8 ; 
      p[x3 + 2] := (z * r) shr 8 ; 
    end; 
  end; 
end; 
 
// ------------- Beispiel -------------------- 

 

procedure TForm1.Button2Click(Sender: TObject); 
var b: TBitmap; 
begin 
  b := TBitmap.create; 
  b.width := 80; 
  b.height := 100; 
  Grad(b, clLime, vlVertical); 
  canvas.draw(10, 10, b); 
  Grad(b, clFuchsia, vlHorizontal); 
  canvas.draw(100, 10, b); 
  Grad(b, clAqua, vlRadial); 
  canvas.draw(190, 10, b); 
  b.free; 
end;

 


Zugriffe seit 6.9.2001 auf Delphi-Ecke