DBR Delphi-Ecke

// Mit dem folgenden Code kann man Text auf einer Zeichenfläche (TCanvas)
// ausgeben, welcher mit einem Schatten hinterlegt ist.

// Getestet mit D4 unter XP

// Variante 1:

// Die Ausgabe kann nur auf einfarbigen Flächen geschehen, da der Einfachheit
// halber nicht nur der Schatten unscharf dargestellt wird, sondern auch der
// Hintergrund, welcher von Schrift und Schatten belegt ist. Aus diesem Grund
// dürfen sich die Schattenschriften auch nicht überlagern. Die Schrift kann
// einfarbig gestaltet sein, oder für jeden (bzw. für mehrere) Buchstaben
// unterschiedliche Farben haben.


type 
  unschaerfe = 0..20; 
 
function SchattenSchrift 
  (cnv: TCanvas; txt, fontname: string; fontsize: integer; 
  fontstyle: TFontstyles; x, y, xversatz, yversatz: integer; 
  fontfarbe: array of TColor; schattenfarbe: TColor; 
  unscharf: unschaerfe; var rct: TRect): boolean; 
var 
  sz: TSize; 
  bm: TBitmap; 
  p: array[0..2] of PBytearray; 
  xv, yv, i, j, k, w, z, li, lg, ob, vd2, txtl, txto: integer; 
begin 
  result := false; 
  lg := length(fontfarbe); 
  if (lg = 0) or (txt = '') then exit; 
  vd2 := unscharf shr 1; 
  xv := abs(xversatz); 
  yv := abs(yversatz); 
  li := ord(xversatz > 0) * xversatz + vd2 + 1; 
  ob := ord(yversatz > 0) * yversatz; 
  txtl := 1 + vd2 + ord(xversatz < 0) * xv; 
  txto := vd2 + ord(yversatz < 0) * yv; 
  dec(x, txtl); 
  dec(y, txto); 
  bm := TBitmap.create; 
  bm.pixelformat := pf24bit; 
  with bm.canvas do begin 
    font.name := fontname; 
    font.color := schattenfarbe; 
    font.size := fontsize; 
    font.style := fontstyle; 
    sz := Textextent(txt); 
    bm.width := 1 + unscharf + sz.cx + xv; 
    bm.height := 1 + unscharf + sz.cy + yv; 
    brush.style := bsclear; 
    rct := rect(x, y, x + bm.width, y + bm.height); 
    bm.canvas.copyrect(rect(0, 0, bm.width, bm.height), cnv, rct); 
    textout(li, ob + vd2, txt); 
    for k := 1 to unscharf do 
      for j := ob + 1 to ob + sz.cy + vd2 do begin 
        for w := 0 to 2 do 
          p[w] := bm.scanline[j - 1 + w]; 
        for i := li to li + sz.cx - 1 do begin 
          z := i * 3; 
          for w := 0 to 2 do 
            p[1][z + w] := round((p[0][z + w] + p[2][z + w] + 
              p[1][(i - 1) * 3 + w] + p[1][(i + 1) * 3 + w]) / 4); 
        end; 
      end; 
    font.color := fontfarbe[0]; 
    textout(txtl, txto, txt[1]); 
    for i := 1 to length(txt) - 1 do begin 
      if lg > i then font.color := fontfarbe[i]; 
      textout(penpos.x, txto, txt[i + 1]); 
    end; 
  end; 
  cnv.draw(x, y, bm); 
  bm.free; 
  result := true; 
end;


// Beispiel 1 (siehe obige Abbildung) 
 
procedure TForm1.Button6Click(Sender: TObject); 
const 
  bunt: array[0..12] of Tcolor = 
  ($80FF80, $80FF80, $80FF80, clnone, $6699FF, $6699FF, $6699FF, clnone, 
    claqua, claqua, claqua, clnone, clyellow); 
  bunt2: array[0..15] of Tcolor = 
  ($BC, clpurple, $66, clnone, $BC, clpurple, $66, clnone, 
    $BC, clpurple, $66, clnone, $BC, clpurple, $66, $BC); 
  bunt3: array[0..8] of Tcolor = 
  (clyellow, clyellow, clyellow, clnone, clyellow, clyellow, clyellow, clnone, 
    cllime); 
var 
  dummy: TRect; 
begin 
  refresh; 
  schattenschrift(canvas, 'Das ist ein Test', 'Arial', 14, [fsBold], 
    30, 20, 3, 3, bunt, clblack, 3, dummy); 
  schattenschrift(canvas, 'Das ist ein Test', 'Arial', 14, [fsBold], 
    30, 52, 0, 0, [$E83322], clblue, 7, dummy); 
  schattenschrift(canvas, 'Das ist ein Test', 'Arial', 14, [fsBold], 
    30, 80, 7, 7, [clred], $666666, 4, dummy); 
  schattenschrift(canvas, 'Das ist ein Test', 'Arial', 14, [fsBold], 
    30, 117, -2, -3, bunt2, $8000FF, 15, dummy); 
  schattenschrift(canvas, 'Das ist ein Test', 'Arial', 14, [fsBold], 
    30, 147, -1, -1, bunt3, $334455, 0, dummy); 
  schattenschrift(canvas, 'Das ist ein Test', 'Arial', 14, [fsBold], 
    30, 172, 1, 1, [$FDFDFD], clblack, 0, dummy); 
end;


// Beispiel 2 
 
var 
  rct: TRect; 
  links, oben: integer; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  doublebuffered := true; 
  canvas.brush.color := color; 
  Edit1.text := ''; 
  rct := rect(0, 0, 0, 0); 
  links := 10; 
  oben := 20; 
end; 
 
procedure TForm1.Edit1KeyUp(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
begin 
  canvas.fillrect(rct); 
  schattenschrift(canvas, Edit1.text, 'Times New Roman', 12, [fsItalic], 
    links, oben, 2, 2, [clblack], clblue, 2, rct); 
end;

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

// Variante 2

// Dieser Code ist nicht für fortlaufendes Eintippen (Beispiel 2 in Variante 1)
// gedacht, sondern nur zur einmaligen Ausgabe. Bunte Schrift muss einzeln
// zusammengesetzt werden. Dafür kann die Schrift aber über Muster und Bilder
// gelegt werden. Durch die Kombination mit dem Hintergrund wird der Schatten
// jedoch etwas blasser. Deshalb darf seine maximale Unschärfe (im Gegensatz zu
// Variante 1) auch nur den Wert "10" haben. Um die Schrift bei Neuzeichnen
// des Fensters nicht zu verlieren, sollten Sie das Ganze vielleicht in ein
// TImage zeichnen lassen.

type 
  unschaerfe = 0..10; 
 
var 
  fontfarbe, schattenfarbe: TColor; 
  schatten, schablone: TBitmap; 
  fontstyle: TFontstyles; 
  fontname, txt: string; 
  fontsize: Integer; 
  sz: TSize; 
 
procedure Einstellungen(cnv: TCanvas; var r, g, b: byte); 
begin 
  with schablone.canvas do begin 
    font.name := fontname; 
    font.size := fontsize; 
    font.style := fontstyle; 
    sz := TextExtent(txt); 
  end; 
  with cnv do begin 
    font.name := fontname; 
    font.color := fontfarbe; 
    font.size := fontsize; 
    font.style := fontstyle; 
    brush.style := bsclear; 
  end; 
  schattenfarbe := colortorgb(schattenfarbe); 
  r := getrvalue(schattenfarbe); 
  g := getgvalue(schattenfarbe); 
  b := getbvalue(schattenfarbe); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  schatten := TBitmap.create; 
  schatten.pixelformat := pf24bit; 
  schablone := TBitmap.create; 
  schablone.pixelformat := pf24bit; 
  schablone.canvas.font.color := 0; 
  schablone.canvas.brush.color := $FFFFFF; 
  txt := ''; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  schatten.free; 
  schablone.free; 
end; 
 
procedure schattenschrift 
  (cnv: TCanvas; x, y, xversatz, yversatz: integer; unscharf: unschaerfe); 
var 
  i, j, k, w, z, li, ob, b3: integer; 
  p: array[0..2] of PBytearray; 
  r, g, b: byte; 
begin 
  if txt = '' then exit; 
  Einstellungen(cnv, r, g, b); 
  schablone.width := sz.cx + unscharf shl 1; 
  schablone.height := sz.cy + unscharf shl 1; 
  b3 := schablone.width * 3; 
  with schablone.canvas do begin 
    fillrect(cliprect); 
    textout(unscharf, unscharf, txt); 
  end; 
  for k := 1 to unscharf do 
    for j := 1 to schablone.height - 2 do begin 
      for w := 0 to 2 do 
        p[w] := schablone.scanline[j - 1 + w]; 
      for i := 1 to schablone.width - 2 do begin 
        z := i * 3; 
        for w := 0 to 2 do 
          p[1][z + w] := (p[0][z + w] + p[2][z + w] + 
            p[1][(i - 1) * 3 + w] + p[1][(i + 1) * 3 + w]) shr 2; 
      end; 
    end; 
  schatten.width := schablone.width; 
  schatten.height := schablone.height; 
  li := x + xversatz - unscharf; 
  ob := y + yversatz - unscharf; 
  schatten.canvas.copyrect(rect(0, 0, schatten.width, schatten.height), 
    cnv, rect(li, ob, li + schatten.width, ob + schatten.height)); 
  for j := 0 to schatten.height - 1 do begin 
    p[0] := schatten.scanline[j]; 
    p[1] := schablone.scanline[j]; 
    i := 0; 
    while i < b3 do begin 
      if p[1][i] <> 255 then begin 
        z := round((256 - p[1][i]) * 1.5); 
        w := z + 256; 
        p[0][i] := (p[0][i] shl 8 + z * b) div w; 
        p[0][i + 1] := (p[0][i + 1] shl 8 + z * g) div w; 
        p[0][i + 2] := (p[0][i + 2] shl 8 + z * r) div w; 
      end; 
      inc(i, 3); 
    end; 
  end; 
  cnv.draw(li, ob, schatten); 
  cnv.textout(x, y, txt); 
end; 
 
 
// Beispiel (Bild bei Variante 2) 
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  refresh; 
  fontname := 'Arial'; 
  fontsize := 14; 
  fontstyle := [fsBold]; 
  txt := 'Das ist ein Test'; 
  schattenfarbe := clblack; 
  fontfarbe := clred; 
  schattenschrift(canvas, 10, 45, 9, 9, 3); 
  fontfarbe := clblack; 
  schattenfarbe := clyellow; 
  schattenschrift(canvas, 10, 80, 0, 0, 7); 
  schattenfarbe := $FF2211; 
  fontfarbe := $FDFDFD; 
  schattenschrift(canvas, 10, 111, 0, -1, 1); 
  schattenfarbe := clblack; 
  fontfarbe := $80FF80; 
  txt := 'Das '; 
  schattenschrift(canvas, 10, 20, 2, 2, 1); 
  fontfarbe := $6699FF; 
  txt := 'ist '; 
  schattenschrift(canvas, canvas.penpos.x, 20, 2, 2, 1); 
  fontfarbe := claqua; 
  txt := 'ein '; 
  schattenschrift(canvas, canvas.penpos.x, 20, 2, 2, 1); 
  fontfarbe := clyellow; 
  txt := 'Test'; 
  schattenschrift(canvas, canvas.penpos.x, 20, 2, 2, 1); 
end;