const 
  max = 5; 
 
type 
  aoc = array [0 .. max] of TColor; 
 
var 
  Farbe: aoc = ($4040FF, clYellow, clLime, clAqua, clFuchsia, $FF9090); 
  Herz, Kreuz, Raute, Rund: array [0 .. max] of TBitmap; 
  Zeichen: array of TBitmap; 
  Mass, M2, MerkC, MerkF: Integer; 
  Basis: TBitmap; 
  r, g, b: Byte; 
 
procedure Erstellen(bmp: TBitmap); 
var 
  X, Y, B3, RA, RB: Integer; 
  p: PByteArray; 
  Bild: TBitmap; 
begin 
  bmp.PixelFormat := pf24Bit; 
  Y := 0; 
  B3 := bmp.Width * 3; 
  while Y < bmp.Height do 
  begin 
    p := bmp.ScanLine[Y]; 
    X := 0; 
    while X < B3 do 
    begin 
      if (b = p[X]) and (g = p[X + 1]) and (r = p[X + 2]) then 
      begin 
        repeat 
          RA := Random(max + 1); 
        until (RA <> MerkC) and (GetPixel(bmp.Canvas.Handle, X div 3, Y - M2) <> 
          GetPixel(Herz[RA].Canvas.Handle, M2, M2)); 
        MerkC := RA; 
        repeat 
          RB := Random(4); 
        until RB <> MerkF; 
        MerkF := RB; 
        case RB of 
          0: 
            Bild := Herz[RA]; 
          1: 
            Bild := Kreuz[RA]; 
          2: 
            Bild := Rund[RA]; 
        else 
          Bild := Raute[RA]; 
        end; 
        bmp.Canvas.Draw(X div 3 - M2, Y - M2, Bild); 
      end; 
      inc(X, 3); 
    end; 
    inc(Y); 
  end; 
end; 
 
function OutlineText(bm: TBitmap; Schrft, Txt: string; SG, Abstand: Integer; 
  Rand, Buchst, Flaeche: TColor; Transparent: Boolean): Boolean; 
var 
  I, J, X, W: Integer; 
  SZ: TSize; 
  LogFont: TLogFont; 
begin 
  Result := False; 
  Rand := ColorToRGB(Rand); 
  Flaeche := ColorToRGB(Flaeche); 
  Buchst := ColorToRGB(Buchst); 
  if (Rand = clBlack) or (Rand = Flaeche) or (Rand = Buchst) then 
    exit; 
  for I := 0 to max do 
    if Rand = ColorToRGB(Farbe[I]) then 
      exit; 
  M2 := Mass div 2; 
  W := 0; 
  MerkC := -1; 
  MerkF := -1; 
  r := GetRValue(Rand); 
  g := GetGValue(Rand); 
  b := GetBValue(Rand); 
  SetLength(Zeichen, Length(Txt)); 
  for X := 0 to High(Zeichen) do 
  begin 
    Zeichen[X] := TBitmap.Create; 
    with Zeichen[X], Canvas do 
    begin 
      Font.Name := Schrft; 
      Font.Size := SG; 
      Brush.Color := Flaeche; 
      GetObject(Font.Handle, SizeOf(TLogFont), @LogFont); 
      LogFont.lfQuality := NONANTIALIASED_QUALITY; 
      Font.Handle := CreateFontIndirect(LogFont); 
      SZ := TextExtent(Txt[X + 1]); 
      SetSize(SZ.cx + Mass, SZ.cy + Mass); 
      inc(W, SZ.cx + Mass + Abstand); 
      Font.Color := Rand; 
      Brush.style := bsclear; 
      for I := 0 to 2 do 
        for J := 0 to 2 do 
          TextOut(M2 + I, M2 + J, Txt[X + 1]); 
      Font.Color := Buchst; 
      TextOut(M2 + 1, M2 + 1, Txt[X + 1]); 
    end; 
  end; 
  with bm, Canvas do 
  begin 
    Brush.Color := Flaeche; 
    I := 0; 
    Width := W; 
    Height := SZ.cy + Mass; 
    Fillrect(Cliprect); 
    for X := 0 to High(Zeichen) do 
    begin 
      Erstellen(Zeichen[X]); 
      Draw(I, 0, Zeichen[X]); 
      inc(I, Zeichen[X].Width + Abstand); 
      FreeAndNil(Zeichen[X]); 
    end; 
  end; 
  Zeichen := nil; 
  bm.Transparent := Transparent; 
  Result := True; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  I: Integer; 
begin 
  for I := 0 to max do 
  begin 
    Herz[I] := TBitmap.Create; 
    Herz[I].LoadFromFile('Herz.bmp'); 
    Herz[I].Canvas.Brush.Color := Farbe[I]; 
    Herz[I].Canvas.FloodFill(Herz[I].Width div 2, Herz[I].Height div 2, clWhite, 
      fsSurface); 
    Herz[I].Transparent := True; 
    Kreuz[I] := TBitmap.Create; 
    Kreuz[I].LoadFromFile('Kreuz.bmp'); 
    Kreuz[I].Canvas.Brush.Color := Farbe[I]; 
    Kreuz[I].Canvas.FloodFill(Kreuz[I].Width div 2, Kreuz[I].Height div 2, 
      clWhite, fsSurface); 
    Kreuz[I].Transparent := True; 
    Raute[I] := TBitmap.Create; 
    Raute[I].LoadFromFile('Raute.bmp'); 
    Raute[I].Canvas.Brush.Color := Farbe[I]; 
    Raute[I].Canvas.FloodFill(Raute[I].Width div 2, Raute[I].Height div 2, 
      clWhite, fsSurface); 
    Raute[I].Transparent := True; 
    Rund[I] := TBitmap.Create; 
    Rund[I].LoadFromFile('Rund.bmp'); 
    Rund[I].Canvas.Brush.Color := Farbe[I]; 
    Rund[I].Canvas.FloodFill(Rund[I].Width div 2, Rund[I].Height div 2, clWhite, 
      fsSurface); 
    Rund[I].Transparent := True; 
  end; 
  Basis := TBitmap.Create; 
  Mass := Herz[0].Width; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  I: Integer; 
begin 
  FreeAndNil(Basis); 
  for I := 0 to max do 
  begin 
    FreeAndNil(Herz[I]); 
    FreeAndNil(Kreuz[I]); 
    FreeAndNil(Raute[I]); 
    FreeAndNil(Rund[I]); 
  end; 
end; 
 
// Beispiel 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if OutlineText(Basis, 'Arial', 'DELPHI', 110, 0, clGray, Color, clSilver, True) 
  then 
    Canvas.Draw(10, 80, Basis) 
  else 
    ShowMessage('Farben überprüfen!'); 
end;

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

// Variante 2 Leicht vereinfachte Variante (ohne Outline) für ein wenig
// kleinere Schriften. Die Variablen sind dieselben wie bei Variante 1

procedure Erstellen(bmp: TBitmap); 
var 
  X, Y, B3, RA, RB: Integer; 
  p: PByteArray; 
  Bild: TBitmap; 
begin 
  bmp.PixelFormat := pf24Bit; 
  Y := 0; 
  B3 := bmp.Width * 3; 
  while Y < bmp.Height do 
  begin 
    p := bmp.ScanLine[Y]; 
    X := 0; 
    while X < B3 do 
    begin 
      if (b = p[X]) and (g = p[X + 1]) and (r = p[X + 2]) then 
      begin 
        repeat 
          RA := Random(max + 1); 
        until (RA <> MerkC) and (GetPixel(bmp.Canvas.Handle, X div 3, Y - M2) <> 
          GetPixel(Herz[RA].Canvas.Handle, M2, M2)); 
        MerkC := RA; 
        repeat 
          RB := Random(4); 
        until RB <> MerkF; 
        MerkF := RB; 
        case RB of 
          0: 
            Bild := Herz[RA]; 
          1: 
            Bild := Kreuz[RA]; 
          2: 
            Bild := Rund[RA]; 
        else 
          Bild := Raute[RA]; 
        end; 
        bmp.Canvas.Draw(X div 3 - M2, Y - M2, Bild); 
      end; 
      inc(X, 9); 
    end; 
    inc(Y, 3); 
  end; 
end;

function MakeText(bm: TBitmap; Schrft, Txt: string; SG: Integer; 
  Buchst, Flaeche: TColor; Transparent: Boolean): Boolean; 
var 
  I, X, W: Integer; 
  SZ: TSize; 
  LogFont: TLogFont; 
begin 
  Result := False; 
  Flaeche := ColorToRGB(Flaeche); 
  Buchst := ColorToRGB(Buchst); 
  if (Buchst = clBlack) or (Buchst = Flaeche) then 
    exit; 
  for I := 0 to max do 
    if Buchst = ColorToRGB(Farbe[I]) then 
      exit; 
  M2 := Mass div 2; 
  W := 0; 
  MerkC := -1; 
  MerkF := -1; 
  r := GetRValue(Buchst); 
  g := GetGValue(Buchst); 
  b := GetBValue(Buchst); 
  SetLength(Zeichen, Length(Txt)); 
  for X := 0 to High(Zeichen) do 
  begin 
    Zeichen[X] := TBitmap.Create; 
    with Zeichen[X], Canvas do 
    begin 
      Font.Name := Schrft; 
      Font.Size := SG; 
      Brush.Color := Flaeche; 
      GetObject(Font.Handle, SizeOf(TLogFont), @LogFont); 
      LogFont.lfQuality := NONANTIALIASED_QUALITY; 
      Font.Handle := CreateFontIndirect(LogFont); 
      SZ := TextExtent(Txt[X + 1]); 
      SetSize(SZ.cx + Mass, SZ.cy + Mass); 
      inc(W, SZ.cx + Mass); 
      Brush.style := bsclear; 
      Font.Color := Buchst; 
      TextOut(M2 + 1, M2 + 1, Txt[X + 1]); 
    end; 
  end; 
  with bm, Canvas do 
  begin 
    Brush.Color := Flaeche; 
    I := 0; 
    Width := W; 
    Height := SZ.cy + Mass; 
    Fillrect(Cliprect); 
    for X := 0 to High(Zeichen) do 
    begin 
      Erstellen(Zeichen[X]); 
      Draw(I, 0, Zeichen[X]); 
      inc(I, Zeichen[X].Width); 
      FreeAndNil(Zeichen[X]); 
    end; 
  end; 
  Zeichen := nil; 
  bm.Transparent := Transparent; 
  Result := True; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  I: Integer; 
begin 
  for I := 0 to max do 
  begin 
    Herz[I] := TBitmap.Create; 
    Herz[I].LoadFromFile('Herz.bmp'); 
    Herz[I].Canvas.Brush.Color := Farbe[I]; 
    Herz[I].Canvas.FloodFill(Herz[I].Width div 2, Herz[I].Height div 2, clWhite, 
      fsSurface); 
    Herz[I].Transparent := True; 
    Kreuz[I] := TBitmap.Create; 
    Kreuz[I].LoadFromFile('Kreuz.bmp'); 
    Kreuz[I].Canvas.Brush.Color := Farbe[I]; 
    Kreuz[I].Canvas.FloodFill(Kreuz[I].Width div 2, Kreuz[I].Height div 2, 
      clWhite, fsSurface); 
    Kreuz[I].Transparent := True; 
    Raute[I] := TBitmap.Create; 
    Raute[I].LoadFromFile('Raute.bmp'); 
    Raute[I].Canvas.Brush.Color := Farbe[I]; 
    Raute[I].Canvas.FloodFill(Raute[I].Width div 2, Raute[I].Height div 2, 
      clWhite, fsSurface); 
    Raute[I].Transparent := True; 
    Rund[I] := TBitmap.Create; 
    Rund[I].LoadFromFile('Rund.bmp'); 
    Rund[I].Canvas.Brush.Color := Farbe[I]; 
    Rund[I].Canvas.FloodFill(Rund[I].Width div 2, Rund[I].Height div 2, clWhite, 
      fsSurface); 
    Rund[I].Transparent := True; 
  end; 
  Basis := TBitmap.Create; 
  Mass := Herz[0].Width; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  I: Integer; 
begin 
  FreeAndNil(Basis); 
  for I := 0 to max do 
  begin 
    FreeAndNil(Herz[I]); 
    FreeAndNil(Kreuz[I]); 
    FreeAndNil(Raute[I]); 
    FreeAndNil(Rund[I]); 
  end; 
end; 
 
// Beispiel 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if MakeText(Basis, 'Calibri', 'Delphi', 65, clGray, $D6FCE7, False) then 
    Canvas.Draw(10, 80, Basis) 
  else 
    ShowMessage('Farben überprüfen!'); 
end; 

 
const 
  sm = 6; 
  max = 8; 
  mass = 7; 
  m2 = mass div 2; 
 
type 
  aoc = array [0 .. max] of TColor; 
 
var 
  Farbe: aoc = (clYellow, clLime, clAqua, clFuchsia, clRed, $AAFF, $5050FF, 
    $FF9090, $60B0FF); 
  XX, YY, MerkX, MerkY, Breit, Hoch, Zeile: Integer; 
  Rund: array [0 .. max] of TBitmap; 
  Flaeche, Buchst, Blink: TColor; 
  Zeichen, H1, H2: TBitmap; 
  Schreibmarke: TImage; 
  lg: array of Integer; 
  r, g, b: Byte; 
  Size: TSize; 
 
function TForm1.Vorbereitung: Boolean; 
var 
  I: Integer; 
  LogFont: TLogFont; 
begin 
  Result := False; 
  Buchst := 1; 
  Flaeche := ColorToRGB(Flaeche); 
  if Flaeche = clBlack then 
    Flaeche := 1; 
  if Buchst = Flaeche then 
    inc(Buchst); 
  for I := 0 to max do 
    if Buchst = ColorToRGB(Farbe[I]) then 
    begin 
      ShowMessage('Farben unzulässig'); 
      exit; 
    end; 
  XX := 0; 
  YY := 0; 
  MerkX := XX; 
  MerkY := YY; 
  Zeile := 0; 
  SetLength(lg, 1); 
  lg[0] := 0; 
  Image1.Canvas.Brush.Color := clBtnFace; // z.B. 
  Image1.Canvas.FillRect(Image1.Canvas.ClipRect); 
  r := GetRValue(Buchst); 
  g := GetGValue(Buchst); 
  b := GetBValue(Buchst); 
  with Zeichen, Canvas do 
  begin 
    Font.Name := 'Courier New'; // unbedingt Schriftart mit fester Breite 
    Font.Size := 37; // empfohlen 
    Font.Style := []; 
    Brush.Color := Flaeche; 
    Font.Color := Buchst; 
    GetObject(Font.Handle, SizeOf(TLogFont), @LogFont); 
    LogFont.lfQuality := NONANTIALIASED_QUALITY; 
    Font.Handle := CreateFontIndirect(LogFont); 
    Size := TextExtent('W'); 
    Breit := Size.cx + mass; 
    Hoch := Size.cy + m2; 
    SetSize(Breit, Hoch); 
  end; 
  with Schreibmarke do 
  begin 
    Autosize := True; 
    with Picture.Bitmap, Canvas do 
    begin 
      Brush.Color := Blink; 
      Width := sm; 
      Height := Hoch; 
    end; 
  end; 
  H1.Canvas.Brush.Color := Flaeche; 
  H1.SetSize(sm, Hoch); 
  H2.Canvas.Brush.Color := Image1.Canvas.Brush.Color; 
  H2.SetSize(sm, Hoch); 
  Stelle; 
  Result := True; 
end; 
 
procedure TForm1.Erstellen(bmp: TBitmap); 
var 
  I, J, B3: Integer; 
  p: PByteArray; 
begin 
  J := 0; 
  B3 := bmp.Width * 3; 
  while J < bmp.Height do 
  begin 
    p := bmp.ScanLine[J]; 
    I := 0; 
    while I < B3 do 
    begin 
      if (b = p[I]) and (g = p[I + 1]) and (r = p[I + 2]) then 
      begin 
        TransparentBlt(bmp.Canvas.Handle, I div 3 - m2, J - m2, mass, mass, 
          Rund[Random(max + 1)].Canvas.Handle, 0, 0, mass, mass, clWhite); 
      end; 
      inc(I, 6); 
    end; 
    inc(J, 2); 
  end; 
end; 
 
procedure TForm1.Buchstabe(C: Char); 
var 
  b: Boolean; 
  procedure go; 
  begin 
    Image1.Canvas.Draw(XX, YY, Zeichen); 
    Image1.Canvas.Draw(XX + Breit, YY, H2); 
  end; 
 
begin 
  b := C = #8; 
  if C = #13 then 
  begin 
    inc(YY, Hoch); 
    inc(Zeile); 
    if Zeile = Length(lg) then 
    begin 
      SetLength(lg, succ(Length(lg))); 
      lg[Zeile] := 0; 
      XX := MerkX; 
    end; 
    ZumEnde; 
  end 
  else 
    with Zeichen, Canvas do 
    begin 
      if b then 
        Brush.Color := Image1.Canvas.Brush.Color 
      else 
        Brush.Color := Flaeche; 
      FillRect(ClipRect); 
      if b then 
      begin 
        if XX = MerkX then 
        begin 
          if YY = MerkY then 
            exit; 
          dec(YY, Hoch); 
          dec(Zeile); 
          XX := MerkX + lg[Zeile] * Breit; 
        end 
        else 
        begin 
          dec(XX, Breit); 
          dec(lg[Zeile]); 
          go; 
        end; 
      end 
      else 
      begin 
        TextOut(m2, m2, C); 
        Erstellen(Zeichen); 
        go; 
        inc(lg[Zeile]); 
        inc(XX, Breit); 
      end; 
    end; 
  Stelle; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  I: Integer; 
begin 
  Self.KeyPreview := True; 
  H1 := TBitmap.Create; 
  H2 := TBitmap.Create; 
  Zeichen := TBitmap.Create; 
  Zeichen.PixelFormat := pf24Bit; 
  for I := 0 to max do 
  begin 
    Rund[I] := TBitmap.Create; 
    Rund[I].SetSize(mass, mass); 
    Rund[I].Canvas.Ellipse(0, 0, mass, mass); 
    Rund[I].Canvas.Brush.Color := Farbe[I]; 
    Rund[I].Canvas.FloodFill(m2, m2, clWhite, fsSurface); 
  end; 
  Timer1.Enabled := False; 
  Timer1.Interval := 250; 
  Schreibmarke := TImage.Create(Self); 
  Schreibmarke.Visible := False; 
  Schreibmarke.parent := Form1; 
  // z.B. ------------------------- 
  Image1.Width := 10000; 
  Image1.Height := Image1.Width; 
  Image1.Left := 10; 
  Image1.Top := 10; 
  // ------------------------------- 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  I: Integer; 
begin 
  for I := 0 to max do 
    FreeAndNil(Rund[I]); 
  FreeAndNil(H1); 
  FreeAndNil(H2); 
  FreeAndNil(Zeichen); 
  FreeAndNil(Schreibmarke); 
  lg := nil; 
end; 
 
procedure TForm1.FormShow(Sender: TObject); 
begin 
  // muss alles nicht an dieser Stelle stehen 
  Flaeche := $DFFFFF; 
  Blink := clBlack; 
  Timer1.Enabled := Vorbereitung; 
  // --------------------------------- 
end; 
 
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  Y := Y div Hoch; 
  if Y > High(lg) then 
    exit 
  else 
  begin 
    Zeile := Y; 
    ZumEnde; 
  end; 
end; 
 
procedure TForm1.Stelle; 
begin 
  Schreibmarke.Left := XX + Image1.Left; 
  Schreibmarke.Top := YY + Image1.Top; 
  // leere Zeile kennzeichnen: 
  // (wirkt nur bei unterschiedlicher Farbe zum Hintergrund) 
  Image1.Canvas.Draw(XX, YY, H1); 
  // --------------------------------------- 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  Schreibmarke.Visible := not Schreibmarke.Visible; 
end; 
 
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
begin 
  if Key = VK_DOWN then 
  begin 
    if (Zeile >= High(lg)) then 
      exit; 
    inc(Zeile); 
    ZumEnde; 
  end 
  else if Key = VK_UP then 
  begin 
    if Zeile > 0 then 
    begin 
      dec(Zeile); 
      ZumEnde; 
    end; 
  end; 
end; 
 
procedure TForm1.ZumEnde; 
begin 
  if XX <> lg[Zeile] * Breit then 
    XX := lg[Zeile] * Breit; 
  YY := Zeile * Hoch; 
  Stelle; 
end; 
 
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); 
begin 
  if Timer1.Enabled then 
    Buchstabe(Key); 
end;