type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    Timer1: TTimer; 
    procedure FormCreate(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
{$R ps.res} // <-------- Ressource einbinden 
 
// ---- für Beispiel 2 ------------------- 
var 
  Untergrund: TColor = $000066; 
  hellePunkte: TColor = $8080FF; 
  dunklePunkte: TColor = $4F4FAF; 
  r, g, b, rh, gh, bh, rd, gd, bd: byte; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Untergrund := ColorToRGB(Untergrund); 
  hellePunkte := ColorToRGB(hellePunkte); 
  dunklePunkte := ColorToRGB(dunklePunkte); 
  r := getrvalue(Untergrund); 
  g := getgvalue(Untergrund); 
  b := getbvalue(Untergrund); 
  rh := getrvalue(hellePunkte); 
  gh := getgvalue(hellePunkte); 
  bh := getbvalue(hellePunkte); 
  rd := getrvalue(dunklePunkte); 
  gd := getgvalue(dunklePunkte); 
  bd := getbvalue(dunklePunkte); 
  Timer1.interval := 0; 
end; 
// --------------------------------------- 
 
procedure farbe(bm: TBitmap); 
var p: PBytearray; 
  x, y, b3: integer; 
begin 
  b3 := bm.width * 3; 
  bm.pixelformat := pf24bit; 
  for y := 0 to bm.height - 1 do begin 
    p := bm.scanline[y]; 
    x := 0; 
    while x < b3 do begin 
      case p[x] of 
        0: begin 
            p[x] := b; 
            p[x + 1] := g; 
            p[x + 2] := r; 
          end; 
        255: begin 
            p[x] := bh; 
            p[x + 1] := gh; 
            p[x + 2] := rh; 
          end; 
      else begin 
          p[x] := bd; 
          p[x + 1] := gd; 
          p[x + 2] := rd; 
        end; 
      end; 
      inc(x, 3); 
    end; 
  end; 
end; 
 
procedure CharToBmp(c: char; bm: TBitmap; faerben: boolean); 
var i: integer; 
begin 
  case c of 
    '!'..'_': i := ord(c) - 31; 
    'Ä': i := 65; 
    'Ö': i := 66; 
    'Ü': i := 67; 
  else i := 1; 
  end; 
  bm.LoadFromResourceID(HInstance, i); 
  if faerben then farbe(bm); 
end; 
 
function StrToBild(cnv: TCanvas; s: string; x, y: integer; 
  zwischenraum, faerben: boolean): TPoint; 
var i, m: integer; 
  b: TBitmap; 
begin 
  m := x; 
  b := TBitmap.create; 
  b.LoadFromResourceID(HInstance, 1); 
  s := ansiuppercase(stringreplace(s, 'ß', 'SS', [rfReplaceAll])); 
  s := stringreplace(s, #13#10, #13, [rfReplaceAll]); 
  s := stringreplace(s, #10, #13, [rfReplaceAll]); 
  s := stringreplace(s, #9, '  ', [rfReplaceAll]); 
  for i := 1 to length(s) do begin 
    if s[i] = #13 then begin 
      inc(y, b.height - ord(not zwischenraum)); 
      x := m; 
    end else begin 
      CharToBmp(s[i], b, faerben); 
      cnv.draw(x, y, b); 
      inc(x, b.width - ord(not zwischenraum)); 
    end; 
  end; 
  result := point(x + b.width, y + b.height); 
  b.free; 
end; 
 
 
 
// Beispielaufruf  1 



procedure TForm1.Button1Click(Sender: TObject); 
begin 
  StrToBild(canvas, ' !"#$%&'#39'()*+,-./0123456789:;<=>?@^_'#13#10 + 
    'abcdefdghijklmnopqrstuvwxyzäöüß[\]', 10, 10, true, false); 
end; 
 
 
// Beispielaufruf  2 


 
var 
  bmp: TBitmap; 
  s: string = 'Das ist ein Test  '; 
  zusehen: integer = 10; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  bmp := TBitmap.create; 
  bmp.width := zusehen * 14; 
  bmp.height := 20; 
  Timer1.interval := 550; 
end; 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Timer1.interval := 0; 
  bmp.free; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  StrToBild(bmp.canvas, copy(s, 0, zusehen), 0, 0, false, true); 
  canvas.draw(10, 100, bmp); 
  bmp.pixelformat := pf8bit; 
  s := copy(s, 2, maxint) + s[1]; 
end;