... 
 private 
    { Private-Deklarationen } 
  public 
    procedure Teile(Hell: Shortint; Grau: Boolean); 
    function Farbe(i, j: Integer): RGBTriple; 
    function Doit(Grphc, Zusatz: TGraphic; Grau: Boolean; Wieviel: Word; 
      Hell: Shortint): Byte; 
    procedure Faerben(Src, Dst: TBitmap; Grau: Boolean; Hell: Shortint); 
    procedure Fehler(Erg: Byte); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
var 
  Gross, Klein, Hlp: TBitmap; 
  Breit, Hoch: Integer; 
  Rt: RGBTriple; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Gross := TBitmap.Create; 
  Klein := TBitmap.Create; 
  Hlp := TBitmap.Create; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  FreeAndNil(Gross); 
  FreeAndNil(Klein); 
  FreeAndNil(Hlp); 
end; 
 
function TForm1.Farbe(i, j: Integer): RGBTriple; 
var 
  Pb: PByteArray; 
  x, y, br, hh: Integer; 
  r, g, b: Byte; 
begin 
  r := 128; 
  g := r; 
  b := r; 
  br := (i + Breit) * 3; 
  if br > Gross.Width * 3 then 
    br := Gross.Width * 3; 
  hh := j + Hoch; 
  if hh > Gross.Height then 
    hh := Gross.Height; 
  for y := j to hh - 1 do 
  begin 
    Pb := Gross.ScanLine[y]; 
    x := i; 
    while x < br do 
    begin 
      r := (r + Pb[x + 2]) shr 1; 
      g := (g + Pb[x + 1]) shr 1; 
      b := (b + Pb[x]) shr 1; 
      inc(x, 3); 
    end; 
  end; 
  Result.RGBTBlue := b; 
  Result.RGBTGreen := g; 
  Result.RGBTRed := r; 
end; 
 
procedure TForm1.Faerben(Src, Dst: TBitmap; Grau: Boolean; Hell: Shortint); 
var 
  p: PByteArray; 
  x, y, b3, gr: Integer; 
  function SetByte(a, b: Integer): Byte; 
  asm 
  ADD  EAX, b 
  CMP  EAX, 255 
  JG   @MAX 
  CMP  EAX, 0 
  JGE  @OK 
  MOV  EAX, 0 
  JMP  @OK 
  @MAX: 
  MOV  EAX,255 
  @OK: 
  end; 
  begin 
    Dst.Width := Src.Width; 
    Dst.Height := Src.Height; 
    Dst.Canvas.draw(0, 0, Src); 
    b3 := Src.Width * 3; 
    for y := 0 to Dst.Height - 1 do 
    begin 
      x := 0; 
      p := Dst.ScanLine[y]; 
      while x < b3 do 
      begin 
        if Grau then 
        begin 
          gr := (p[x] + p[x + 1] + p[x + 2]) div 3; 
          p[x] := SetByte((Rt.RGBTBlue * gr) shr 8, Hell); 
          p[x + 1] := SetByte((Rt.RGBTGreen * gr) shr 8, Hell); 
          p[x + 2] := SetByte((Rt.RGBTRed * gr) shr 8, Hell); 
        end 
        else 
        begin 
          p[x] := SetByte((Rt.RGBTBlue * p[x]) shr 8, Hell); 
          p[x + 1] := SetByte((Rt.RGBTGreen * p[x + 1]) shr 8, Hell); 
          p[x + 2] := SetByte((Rt.RGBTRed * p[x + 2]) shr 8, Hell); 
        end; 
        inc(x, 3); 
      end; 
    end; 
  end; 
 
  procedure TForm1.Teile(Hell: Shortint; Grau: Boolean); 
  var 
    x, y: Integer; 
  begin 
    for y := 0 to Gross.Height div Hoch do 
      for x := 0 to Gross.Width div Breit do 
      begin 
        Rt := Farbe(x * Breit, y * Hoch); 
        Faerben(Klein, Hlp, Grau, Hell); 
        Gross.Canvas.draw(x * Breit, y * Hoch, Hlp); 
      end; 
  end; 
 
  function TForm1.Doit(Grphc, Zusatz: TGraphic; Grau: Boolean; Wieviel: Word; 
    Hell: Shortint): Byte; 
  var 
    f: Single; 
  begin 
    try 
      if (Wieviel < 2) then 
      begin 
        Result := 1; 
        exit; 
      end; 
      Gross.PixelFormat := pf24Bit; 
      Klein.PixelFormat := pf24Bit; 
      Hlp.PixelFormat := pf24Bit; 
      Gross.Width := Grphc.Width; 
      Gross.Height := Grphc.Height; 
      if (Gross.Width < 30) or (Gross.Height < 30) then 
      begin 
        Result := 2; 
        exit; 
      end; 
      Gross.Canvas.draw(0, 0, Grphc); 
      f := Gross.Width / Gross.Height; 
      Breit := (Gross.Width div (Wieviel * 3)) * 3; 
      Hoch := round(Breit / f); 
      if (Breit < 3) or (Hoch < 3) then 
      begin 
        Result := 3; 
        exit; 
      end; 
      if Gross.Width < Breit * 2 then 
      begin 
        Result := 4; 
        exit; 
      end; 
      Klein.Width := Breit; 
      Klein.Height := Hoch; 
      SetStretchBltMode(Klein.Canvas.handle, STRETCH_HALFTONE); 
      if Zusatz = nil then 
        Klein.Canvas.StretchDraw(Klein.Canvas.ClipRect, Gross) 
      else 
        Klein.Canvas.StretchDraw(Klein.Canvas.ClipRect, Zusatz); 
      Teile(Hell, Grau); 
      Result := 0; 
    except 
      Result := 5; 
    end; 
  end; 
 
  procedure TForm1.Fehler(Erg: Byte); 
  var 
    Meldung: string; 
  begin 
    case Erg of 
      1: 
        Meldung := 
          'Die Anzahl der waagerechten Teilbilder muss mindestens 2 sein.'; 
      2: 
        Meldung := 'Das Original ist viel zu klein.'; 
      3: 
        Meldung := 
          'Die Anzahl der Teilbilder ist zu hoch im Verhältnis zum Original.'; 
      4: 
        Meldung := 'Die Abmessungen des großen Bildes sind etwas zu gering'; 
      else 
        Meldung := 'Es ist ein unerwarteter Fehler aufgetreten'; 
      end; 
    Messagebox(handle, 
      PChar(Meldung + #13#10 + 'Der Vorgang wird abgebrochen!'), 'ACHTUNG', 
      MB_ICONERROR); 
  end;

 
// Beispielaufruf 1: Ohne zusätzliches Bild (kleines Bild grau) 
  procedure TForm1.Button1Click(Sender: TObject); 
  var 
    Ergebnis: Byte; 
    Teilbilder: Word; 
    Helligkeit: Shortint; 
    Grau: Boolean; 
  begin 
    Teilbilder := 28; // z.B. 
    Helligkeit := 33; // z.B. 
    Grau := True; 
    Ergebnis := Doit(Image1.Picture.Graphic, Nil, Grau, Teilbilder, Helligkeit); 
    if Ergebnis > 0 then 
      Fehler(Ergebnis) 
    else 
      Image2.Picture.Assign(Gross); // z.B. 
  end; 
 
// Beispielaufruf 2: Mit zusätzlichem Bild (Roter Ring) 
  procedure TForm1.Button2Click(Sender: TObject); 
  var 
    Erg: Byte; 
    Zus: TBitmap; 
  begin 
    Zus := TBitmap.Create; 
    Zus.LoadFromFile('D:\Bilder\Testk.bmp'); // z.B. 
    Erg := Doit(Image1.Picture.Graphic, Zus, False, 40, 15); 
    if Erg > 0 then 
      Fehler(Erg) 
    else 
      Image2.Picture.Assign(Gross); 
  end;