DBR Delphi-Ecke

// 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;