// Eine buchstabenweise erscheinende Schrift wird in ein animiertes
// GIF gespeichert. Wann und wo man das gebrauchen kann, weiß ich auch
// nicht so ganz genau. Um das Ganze ordnungsgemäß optimieren zu können
// werden die Buchstaben nicht auf die Form, sondern zunächst auf eine
// Bitmap geschrieben.

// Es wurden 4 verschiedene Erscheinungsarten der Schrift eingearbeitet:






// Getestet mit RS 10.4 unter Win11

unit Unit1; 
 
interface 
 
uses 
  Winapi.Windows, Winapi.Messages, System.SysUtils, 
  System.Classes, Vcl.Graphics, Vcl.Imaging.GIFImg, 
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
type 
  Kind = (yNormal, y3D1, y3D2, yOutLine); 
 
var 
  Txt: String = 'Das ist eine Möglichkeit'#13 + 'Einzelbilder von einer'#13 + 
    'Buchstabe für Buchstabe'#13 + 'entstehenden Schrift'#13 + 
    'zum GIF zu verarbeiten.'; 
 
  PXO, PX, PYO, PY, BAbst, ZAbst, Stelle, TxtH, Tiefe: Integer; 
  Ordner: String = 'D:\Versuch'; // Zielordner 
  Fertig: String = 'Animation.gif'; // z.B. 
  D3, MitOptimierung: Boolean; 
  Endung: String = '.bmp'; 
  Einzel: String = 'Fase'; 
  FarbeV, FarbeH: TColor; 
  Zahl: Integer = 0; 
  bm, hlp: TBitmap; 
  RCT: TRect; 
  br: String; 
  knd: Kind; 
 
procedure Save(cnv: TCanvas); 
begin 
  hlp.SetSize(RCT.Right - RCT.Left, RCT.Bottom - RCT.Top); 
  hlp.Canvas.CopyRect(hlp.Canvas.Cliprect, cnv, RCT); 
  hlp.SaveTofile(Ordner + Einzel + Format('%.' + br + 'd', [Zahl]) + Endung); 
  inc(Zahl); 
end; 
 
procedure schrift3d(cnv: TCanvas; Txt: string; x, y: Integer; Art: Boolean); 
var 
  i, offs: Integer; 
begin 
  offs := ord(Art) * Tiefe; 
  cnv.Font.color := FarbeH; 
  cnv.Brush.style := bsclear; 
  i := 1; 
  repeat 
    cnv.textout(x + i, y + i, Txt); 
    inc(i); 
  until i > Tiefe; 
  cnv.Font.color := FarbeV; 
  cnv.textout(x + offs, y + offs, Txt); 
end; 
 
procedure OutlineText(cnv: TCanvas; Txt: string; x, y: Integer); 
var 
  i, j: Integer; 
begin 
  with cnv do 
  begin 
    Font.color := FarbeV; 
    Brush.style := bsclear; 
    for i := -1 to 1 do 
      for j := -1 to 1 do 
        textout(x + i, y + j, Txt); 
    Font.color := FarbeH; 
    textout(x, y, Txt); 
  end; 
end; 
 
procedure Go(cnv: TCanvas; rectangleonly: Boolean); 
var 
  i, o, w, Rand: Integer; 
begin 
  PX := PXO; 
  PY := PYO; 
  Stelle := 0; 
  Rand := 7; // Seitenränder 
  TxtH := bm.Canvas.TextHeight(Txt); 
  for i := 1 to Length(Txt) do 
  begin 
    o := ord(Txt[i]); 
    if o = 13 then 
    begin 
      PX := PXO; 
      inc(PY, TxtH + ZAbst + Tiefe); 
    end 
    else 
    begin 
      w := bm.Canvas.TextWidth(Txt[i]); 
      if not rectangleonly then 
      begin 
        // Umweg über Bitmap wegen Optimierung 
        bm.SetSize(w + Tiefe, TxtH + Tiefe); 
        bm.Canvas.Brush.color := Form1.color; 
        bm.Canvas.Fillrect(bm.Canvas.Cliprect); 
        case knd of 
          y3D1, y3D2: 
            schrift3d(bm.Canvas, Txt[i], 0, 0, D3); 
          yOutLine: 
            OutlineText(bm.Canvas, Txt[i], 0, 0); 
        else 
          bm.Canvas.textout(0, 0, Txt[i]); 
        end; 
        cnv.Draw(PX, PY, bm); 
        Application.ProcessMessages; 
        sleep(50); // für besseres Mitverfolgen 
      end; 
      inc(PX, w + BAbst + Tiefe); 
      if rectangleonly then 
      begin 
        if PX > Stelle then 
          Stelle := PX; 
      end 
      else if not(o in [32, 160]) then // für flüssiges Anzeigen 
      begin 
        Save(cnv); 
      end; 
    end; 
  end; 
  RCT := Rect(PXO - Rand, PYO - Rand + Tiefe, Stelle + Rand, 
    PY + TxtH + Rand + Tiefe); 
end; 
 
procedure MakeAnimGIF(Dateiname: TFilename; loop: Byte; optimize: Boolean); 
var 
  GIF: TGIFImage; 
  Frame: TGIFFrame; 
  GCExt: TGIFGraphicControlExtension; 
  LoopExt: TGIFAppExtNSLoop; 
  i: Integer; 
  z: Byte; 
begin 
  GIF := TGIFImage.Create; 
  try 
    bm.LoadFromFile(Ordner + Einzel + Format('%.' + br + 'd', [0]) + Endung); 
    Frame := GIF.Add(bm); 
    if loop <> 1 then 
    begin 
      if loop = 0 then // Schleife 
        z := 0 
      else 
        z := pred(loop); 
      LoopExt := TGIFAppExtNSLoop.Create(Frame); 
      LoopExt.Loops := z; 
    end; 
    GCExt := TGIFGraphicControlExtension.Create(Frame); 
    GCExt.Delay := 50; // Bild-Dauer Anfangsbild 
    for i := 1 to pred(Zahl) do 
    begin 
      bm.LoadFromFile(Ordner + Einzel + Format('%.' + br + 'd', [i]) + Endung); 
      Frame := GIF.Add(bm); 
      GCExt := TGIFGraphicControlExtension.Create(Frame); 
      if i = pred(Zahl) then 
        GCExt.Delay := 250 // Bild-Dauer letztes Bild 
      else 
        GCExt.Delay := 10; 
    end; 
    GIF.OptimizeColorMap; 
    if optimize then 
      GIF.optimize([ooCrop, ooMerge, ooColorMap], rmNone, dmNearest, 0); 
    GIF.SaveTofile(Dateiname); 
  except 
    ShowMessage('FEHLER'); 
  end; 
  FreeAndNil(GIF); 
end; 
 
procedure DeleteF(pfad: string); 
var 
  sr: TWin32FindData; 
  h: THandle; 
begin 
  h := FindFirstFile(PChar(pfad + Einzel + '*' + Endung), sr); 
  if h <> INVALID_HANDLE_VALUE then 
    repeat 
      if sr.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then 
        DeleteFile(pfad + sr.cFileName); 
    until Findnextfile(h, sr) = False; 
  Winapi.Windows.FindClose(h); 
  DeleteFile(pfad + Fertig); 
end; 
 
function Vornullen: String; // Vornullenanzahl begrenzen 
var 
  s: string; 
begin 
  s := StringReplace(Txt, #32, '', [rfreplaceall]); 
  s := StringReplace(s, #160, '', [rfreplaceall]); 
  Result := IntToStr(Length(IntToStr(Length(s)))); 
end; 
 
function SetFontAlias(Font: TFont): Boolean; 
var 
  LogFont: TLogFont; 
begin 
  Result := True; 
  if not MitOptimierung then 
    exit; 
  try 
    if GetObject(Font.Handle, SizeOf(TLogFont), @LogFont) = 0 then 
      exit; 
    LogFont.lfQuality := NONANTIALIASED_QUALITY; 
    Font.Handle := CreateFontIndirect(LogFont); 
  except 
    Result := False; 
  end; 
end; 
 
procedure WelcheArt(K: Kind); 
begin 
  knd := K; 
  case K of 
    y3D1: 
      begin 
        Tiefe := 4; // z.B. 
        BAbst := -2; // Buchstabenabstand, 0 = normal 
        D3 := True; 
      end; 
    y3D2: 
      begin 
        Tiefe := 4; 
        BAbst := -2; 
        D3 := False; 
      end; 
    yOutLine: 
      begin 
        Tiefe := 1; 
        BAbst := 1; 
      end; 
  else 
    begin 
      Tiefe := 0; 
      BAbst := 0; 
    end; 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bm := TBitmap.Create; 
  hlp := TBitmap.Create; 
  color := $B0FFFF; // z.B. helles Gelb 
  if Ansilastchar(Ordner) <> '\' then 
    Ordner := Ordner + '\'; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  FreeAndNil(hlp); 
  FreeAndNil(bm); 
end; 
 


// --- Beispielaufrufe --- 
 
// Einzelbilder erstellen und speichern 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Screen.Cursor := crHourglass; 
  TButton(Sender).Enabled := False; 
  DeleteF(Ordner); // alte Dateien bei Bedarf löschen 
  Application.ProcessMessages; 
  FarbeV := $FF2020; // z.B. 
  FarbeH := clSilver; // z.B. 
  MitOptimierung := True; // unbedingt vor "SetFontAlias" 
  { MitOptimierung := False; // besseres Schriftbild } 
  with bm do 
  begin 
    Canvas.Brush.color := Form1.color; 
    Canvas.Font.Name := 'Arial'; 
    Canvas.Font.Size := 18; 
    Canvas.Font.style := [fsBold]; 
    Canvas.Font.color := FarbeV; 
    SetFontAlias(Canvas.Font); 
  end; 
  WelcheArt(y3D1); 
  PXO := 50; // links 
  PYO := 30; // oben 
  ZAbst := 0; // Zeilenabstand, 0 = normal 
  Refresh; // falls Wiederholung Form leeren 
  Go(Canvas, True); // benötigtes Rechteck ermitteln 
  br := Vornullen; 
  ForceDirectories(Ordner); // Ordner erzeugen, falls nicht vorhanden 
  Zahl := 0; 
  Save(Canvas); // leeres Bild erzeugen 
  Go(Canvas, False); // Einzel-Bilder speichern 
  TButton(Sender).Enabled := True; 
  Screen.Cursor := crDefault; 
end; 
 
// gleich anschließend animiertes Gif erstellen 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  Loops: Byte; 
begin 
  if Zahl > 1 then 
  begin 
    Screen.Cursor := crHourglass; 
    TButton(Sender).Enabled := False; 
    Loops := 0; 
    MakeAnimGIF(Ordner + Fertig, Loops, MitOptimierung); 
    TButton(Sender).Enabled := True; 
    Screen.Cursor := crDefault; 
  end; 
end; 
 
end.

Zugriffe seit 6.9.2001 auf Delphi-Ecke