DBR Delphi-Ecke

// Eine 3D-Schrift "wächst" scheinbar aus dem Formular heraus.

// Getestet mit D4 unter XP

// Variante 1: Die Buchstaben erscheinen einzeln

var 
  ai: array of TImage; 
  txt: string = 'DELPHI'; 
  lg: integer; 
  links: integer = 10; 
  grundlinie: integer = 55; 
  tiefe: integer = 7; 
  fase: integer = 0; 
  Randfarbe: TColor = clnavy; 
  Farbe: TColor = $FF9999; 
  Buchstabe: integer = 0; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  x, l: integer; 
  sz: TSize; 
begin 
  Timer1.interval := 0; 
  doublebuffered := true; 
  lg := length(txt); 
  setlength(ai, lg); 
  for x := lg - 1 downto 0 do begin 
    ai[x] := TImage.create(self); 
    with ai[x] do begin 
      autosize := true; 
      parent := self; 
      with picture.bitmap, canvas do begin 
        font.name := 'Times New Roman'; 
        font.size := 32; 
        font.style := [fsbold]; 
        sz := Textextent(txt[x + 1]); 
        width := sz.cx + tiefe; 
        height := sz.cy + tiefe; 
        brush.color := self.color; 
        fillrect(cliprect); 
        brush.style := bsclear; 
      end; 
      top := grundlinie - height; 
    end; 
  end; 
  l := links; 
  for x := 0 to lg - 1 do begin 
    ai[x].left := l; 
    inc(l, ai[x].width - tiefe + 1); 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  x: integer; 
begin 
  for x := 0 to lg - 1 do ai[x].free; 
  ai := nil; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  with ai[buchstabe].picture.bitmap.canvas do begin 
    Font.color := Randfarbe; 
    textout(fase, fase, txt[buchstabe + 1]); 
    inc(fase); 
    Font.color := Farbe; 
    textout(fase, fase, txt[buchstabe + 1]); 
    if fase = tiefe then begin 
      ai[buchstabe].transparent := true; 
      fase := 0; 
      inc(buchstabe); 
      if buchstabe = lg then begin 
        Timer1.interval := 0; 
        buchstabe := 0; 
      end; 
    end; 
  end; 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Timer1.interval := 44; 
end;

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

// Variante 2: Die Schrift erscheint in ganzer Breite

var 
  ai: array of TImage; 
  txt: string = 'DELPHI'; 
  lg: integer; 
  links: integer = 10; 
  grundlinie: integer = 55; 
  tiefe: integer = 7; 
  fase: integer = 0; 
  Randfarbe: TColor = clnavy; 
  Farbe: TColor = $FF9999; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  x, l: integer; 
  sz: TSize; 
begin 
  Timer1.interval := 0; 
  doublebuffered := true; 
  lg := length(txt); 
  setlength(ai, lg); 
  for x := lg - 1 downto 0 do begin 
    ai[x] := TImage.create(self); 
    with ai[x] do begin 
      autosize := true; 
      parent := self; 
      transparent := true; 
      with picture.bitmap, canvas do begin 
        font.name := 'Times New Roman'; 
        font.size := 32; 
        font.style := [fsbold]; 
        sz := Textextent(txt[x + 1]); 
        width := sz.cx + tiefe; 
        height := sz.cy + tiefe; 
        brush.color := self.color; 
        fillrect(cliprect); 
        brush.style := bsclear; 
      end; 
      top := grundlinie - height; 
    end; 
  end; 
  l := links; 
  for x := 0 to lg - 1 do begin 
    ai[x].left := l; 
    inc(l, ai[x].width - tiefe + 1); 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  x: integer; 
begin 
  for x := 0 to lg - 1 do ai[x].free; 
  ai := nil; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
var x: integer; 
begin 
  for x := 1 to lg do begin 
    with ai[x - 1].picture.bitmap.canvas do begin 
      Font.color := Randfarbe; 
      textout(fase, fase, txt[x]); 
    end; 
  end; 
  inc(fase); 
  for x := 1 to lg do begin 
    with ai[x - 1].picture.bitmap.canvas do begin 
      Font.color := Farbe; 
      textout(fase, fase, txt[x]); 
    end; 
  end; 
  if fase = tiefe then begin 
    fase := 0; 
    Timer1.interval := 0; 
  end; 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Timer1.interval := 44; 
end;

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

// Variante 3: Wenn die Schrift nicht animiert sein muss, sondern
// beispielsweise eingetippt werden soll, kann man den 3D-Rand mittels
// Linien zeichnen. Das ergibt ein homogenes Bild.

type 
  richtung = (rechtsunten, rechtsoben, linksunten, linksoben); 
 
procedure d3 
  (bm: TBitmap; Untergrund, Fontcolor, Rand: TColor; 
  Tiefe: Byte; Fontsize: integer; Fontstyle: TFontstyles; 
  Fontname, txt: string; wohin: richtung); 
var 
  sz: TSize; 
  x, y: integer; 
begin 
  Untergrund := colorToRGB(Untergrund); 
  Fontcolor := colorToRGB(Fontcolor); 
  Rand := colorToRGB(Rand); 
  with bm, canvas do begin 
    Font.name := Fontname; 
    Font.size := Fontsize; 
    Font.style := Fontstyle; 
    Font.color := Fontcolor; 
    sz := textextent(txt); 
    width := sz.cx + Tiefe + 5; // workaround for Italic bug 
    height := sz.cy + Tiefe; 
    brush.color := Untergrund; 
    fillrect(cliprect); 
    brush.style := bsclear; 
    pen.color := Rand; 
    case wohin of 
      rechtsoben: begin 
          Textout(0, Tiefe, txt); 
          for y := 0 to bm.height - Tiefe do 
            for x := bm.width - Tiefe downto 0 do begin 
              if (pixels[x, y] <> Untergrund) and (pixels[x, y] <> Rand) 
                then begin 
                moveto(x + 1, y - 1); 
                lineto(x + Tiefe, y - Tiefe); 
              end; 
            end; 
          Textout(0, Tiefe, txt); 
        end; 
      rechtsunten: begin 
          Textout(0, 0, txt); 
          for y := bm.height - Tiefe downto 0 do 
            for x := bm.width - Tiefe downto 0 do begin 
              if (pixels[x, y] <> Untergrund) and (pixels[x, y] <> Rand) 
                then begin 
                moveto(x + 1, y + 1); 
                lineto(x + Tiefe, y + Tiefe); 
              end; 
            end; 
          Textout(0, 0, txt); 
        end; 
      linksoben: begin 
          Textout(Tiefe, Tiefe, txt); 
          for y := Tiefe to bm.height - 1 do 
            for x := Tiefe to bm.width - 1 do begin 
              if (pixels[x, y] <> Untergrund) and (pixels[x, y] <> Rand) 
                then begin 
                moveto(x - 1, y - 1); 
                lineto(x - Tiefe, y - Tiefe); 
              end; 
            end; 
          Textout(Tiefe, Tiefe, txt); 
        end; 
    else begin 
        Textout(Tiefe, 0, txt); 
        for y := bm.height - 1 downto Tiefe do 
          for x := Tiefe to bm.width - 1 do begin 
            if (pixels[x, y] <> Untergrund) and (pixels[x, y] <> Rand) 
              then begin 
              moveto(x - 1, y + 1); 
              lineto(x - Tiefe, y + Tiefe); 
            end; 
          end; 
        Textout(Tiefe, 0, txt); 
      end; 
    end; 
  end; 
end; 
 
// Beispielaufrufe 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  doublebuffered := true; 
  Edit1.Text := ''; 
  Image1.autosize := true; 
  Image1.transparent := true; 
  Image2.autosize := true; 
  Image2.transparent := true; 
end; 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  d3(Image1.Picture.Bitmap, clBtnFace, clRed, $000066, 10, 32, 
    [fsBold, fsItalic], 'Times New Roman', 'DELPHI', linksoben); 
  Image1.refresh; 
end; 
 
procedure TForm1.Edit1Change(Sender: TObject); 
begin 
  d3(Image2.Picture.Bitmap, clBtnFace, clblue, $FF9999, 7, 34, 
    [fsBold, fsUnderline], 'Courier New', Edit1.text, rechtsunten); 
  Image2.refresh; 
end;

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

// Variante 4: Simple Variante

procedure schrift3d(cnv: TCanvas; txt, FontName: string; 
  FontSize, x, y, Tiefe: integer; FarbeRand, FarbeFront: TColor; 
  Richtung: boolean); 
var i: integer; 
begin 
  cnv.Brush.style := bsclear; 
  cnv.Font.color := FarbeRand; 
  cnv.Font.Name := Fontname; 
  cnv.Font.Size := Fontsize; 
  i := 0; 
  repeat 
    cnv.textout(x + i, y + i, txt); 
    if Richtung then inc(i) 
    else dec(i); 
  until abs(i) = abs(Tiefe); 
  cnv.Font.color := FarbeFront; 
  cnv.textout(x + i, y + i, txt); 
end; 
 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  schrift3D(Canvas, 'Das ist ein Test', 'Arial', 18, 10, 20, 4, 
  $FF9292, clblue, false); 
end;