type 
  pc = ^TColor; 
 
var 
  bm, vierkant: TBitmap; 
 
  // für animiertes Beispiel 
  hlp: TBitmap; 
  fase: integer = 0; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  vierkant := TBitmap.create; 
  bm := TBitmap.create; 
  bm.loadfromfile('c:\Ruf.bmp'); 
 
  hlp := TBitmap.create; 
  hlp.width := bm.width; 
  hlp.height := bm.height; 
  Timer1.interval := 20; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bm.free; 
  vierkant.free; 
 
  hlp.free; 
end; 
 
function mach(src, dst: TBitmap; grund: TColor; 
  rand, zu: pc; variante: boolean; lus: byte; zeichnen: boolean = true): TPoint; 
var 
  xs, xd, y, z, schmal, breit, 
    w3, s3, b3, g3, z1, z2, z3, z4: integer; 
  ps, pd: PBytearray; 
  r, g, b, rz, gz, bz: byte; 
  function SetByte(i: integer): byte; 
  asm 
  CMP  EAX, 255 
  JG   @MAX 
  CMP  EAX, 0 
  JGE  @OK 
  MOV  EAX, 0 
  JMP  @OK 
@MAX: 
  MOV  EAX,255 
@OK: 
  end; 
  procedure strich; 
  begin 
    pd[xd] := b; 
    pd[xd + 1] := g; 
    pd[xd + 2] := r; 
  end; 
  procedure oben; 
  begin 
    pd[xd] := bz; 
    pd[xd + 1] := gz; 
    pd[xd + 2] := rz; 
  end; 
begin 
  result := point(0, 0); 
  try 
    if (src = nil) or (src.width < 24) 
      or (src.width / src.height > 3) 
      then exit; 
    schmal := src.width div 9; 
    breit := src.width div 3; 
    if zeichnen then begin 
      dst.width := breit + schmal; 
      dst.height := src.height + schmal; 
      if rand <> nil then begin 
        rand^ := ColorToRGB(rand^); 
        r := getrvalue(rand^); 
        g := getgvalue(rand^); 
        b := getbvalue(rand^); 
      end; 
      if zu <> nil then begin 
        zu^ := ColorToRGB(zu^); 
        rz := getrvalue(zu^); 
        gz := getgvalue(zu^); 
        bz := getbvalue(zu^); 
      end; 
      src.pixelformat := pf24bit; 
      dst.pixelformat := pf24bit; 
      w3 := src.width * 3; 
      s3 := schmal * 3; 
      b3 := breit * 3; 
      g3 := s3 + b3; 
      with dst.canvas do begin 
        brush.color := grund; 
        fillrect(cliprect); 
      end; 
      if variante then begin 
        z1 := 0; 
        z2 := s3; 
        z3 := w3 - g3; 
        z4 := w3 - b3; 
      end else begin 
        z1 := b3; 
        z2 := g3 + 3; 
        z3 := w3 - s3; 
        z4 := 0; 
      end; 
// hinten 
      for y := 0 to schmal do begin 
        xs := z4; 
        xd := b3; 
        ps := src.scanline[y]; 
        pd := dst.scanline[y]; 
        while xd > 0 do begin 
          if zu <> nil then oben else begin 
            if (xd = b3) and (rand <> nil) then strich 
            else begin 
              pd[xd] := setbyte(ps[xs] - lus); 
              pd[xd + 1] := setbyte(ps[xs + 1] - lus); 
              pd[xd + 2] := setbyte(ps[xs + 2] - lus); 
            end; 
          end; 
          inc(xs, 3); 
          dec(xd, 3); 
        end; 
      end; 
// rechts 
      for y := 0 to schmal do begin 
        xs := z3; 
        xd := g3; 
        z := schmal; 
        ps := src.scanline[y]; 
        while xd > b3 do begin 
          pd := dst.scanline[y + z]; 
          dec(z); 
          if zu <> nil then oben 
          else begin 
            pd[xd] := setbyte(ps[xs] - lus); 
            pd[xd + 1] := setbyte(ps[xs + 1] - lus); 
            pd[xd + 2] := setbyte(ps[xs + 2] - lus); 
          end; 
          inc(xs, 3); 
          dec(xd, 3); 
        end; 
      end; 
// links 
      for y := 0 to src.height - 1 do begin 
        xs := z1; 
        xd := 0; 
        ps := src.scanline[y]; 
        while xd < s3 do begin 
          pd := dst.scanline[y + xd div 3]; 
          if (y = 0) and (rand <> nil) then strich 
          else begin 
            pd[xd] := setbyte(ps[xs] + lus); 
            pd[xd + 1] := setbyte(ps[xs + 1] + lus); 
            pd[xd + 2] := setbyte(ps[xs + 2] + lus); 
          end; 
          inc(xs, 3); 
          inc(xd, 3); 
        end; 
      end; 
// vorn 
      for y := 0 to src.height - 1 do begin 
        xs := z2; 
        xd := s3; 
        ps := src.scanline[y]; 
        pd := dst.scanline[y + schmal]; 
        while xd < g3 do begin 
          if (rand <> nil) and ((xs = z2) or (y = 0)) 
            then strich 
          else begin 
            pd[xd] := ps[xs]; 
            pd[xd + 1] := ps[xs + 1]; 
            pd[xd + 2] := ps[xs + 2]; 
          end; 
          inc(xs, 3); 
          inc(xd, 3); 
        end; 
      end; 
    end; 
    result := point(breit + schmal, src.height + schmal); 
  except 
  end; 
end; 
 
function CalculateTube(bm: TBitmap): TPoint; 
begin 
  result := mach(bm, nil, 0, nil, nil, false, 0, false); 
end;

 
// ---------- Beispiele ---------- 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  pr, pg: pc; 
  c, g: TColor; 
  p: TPoint; 
begin 
  pr := @c; 
  pg := @g; 
 
// Beispiel 1 
  g := $5555EE; 
  if mach(bm, vierkant, color, nil, pg, false, 70).x > 0 then 
    canvas.draw(30, 30, vierkant) else 
    showmessage('Fehler 1'); 
 
// Beispiel 2 
  c := clWhite; 
  g := $E0; 
  if mach(bm, vierkant, color, pr, pg, false, 0).x > 0 then 
    canvas.draw(180, 30, vierkant) else 
    showmessage('Fehler 1'); 
 
// Beispiel 3 
  c := $8080EE; 
  if mach(bm, vierkant, color, pr, nil, true, 0).x > 0 then 
    canvas.draw(330, 30, vierkant) else 
    showmessage('Fehler 3'); 
 
// Beispiel 4 
  if mach(bm, vierkant, color, nil, nil, true, 42).x > 0 then 
    canvas.draw(480, 30, vierkant) else 
    showmessage('Fehler 4'); 
 
// Beispiel 5 (nur Röhren-Abmaße abfragen) 
  p := CalculateTube(bm); 
  if p.x = 0 then showmessage('Fehler') else 
    showmessage('Zielbitmap hat ' + inttostr(p.x) + ' x ' + 
      inttostr(p.y) + ' Pixel'); 
end;

 
// Animiertes Beispiel. Das Bild läuft um die Röhre 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  hlp.canvas.copyrect(rect(0, 0, fase, bm.height), bm.canvas, 
    rect(bm.width - fase, 0, bm.width, bm.height)); 
  hlp.canvas.copyrect(rect(fase, 0, bm.width, bm.height), bm.canvas, 
    rect(0, 0, bm.width - fase, bm.height)); 
  inc(fase); 
  if fase >= bm.width then fase := 0; 
  if mach(hlp, vierkant, color, nil, nil, false, 66).x = 0 
    then begin 
    Timer1.enabled := false; 
    showmessage('Animations-Fehler'); 
  end else 
    canvas.draw(30, 250, vierkant) 
end;