// Bitmap in Bitmap verstecken 
 
procedure BMPinBMP(original, container: TBitmap); 
var 
  arr: array of byte; 
  o, x, y, z, w, b3, lg, lk, so: integer; 
  p: PBytearray; 
  kennung: string; 
begin 
  kennung := 'BiB'; 
  b3 := original.width * 3; 
  o := b3 * original.height; 
  lk := length(kennung); 
  so := sizeof(integer); 
  w := so * 2 + lk; 
  if (o > container.width * pred(container.height)) 
    or (container.width < w) 
    then showmessage('Container zu klein') 
  else begin 
    setlength(arr, o + w); 
    x := original.width; 
    y := original.height; 
    lg := high(arr); 
    for z := 0 to lk - 1 do 
      arr[z] := ord(kennung[z + 1]); 
    copymemory(@arr[lk], @x, so); 
    copymemory(@arr[lk + so], @y, so); 
    z := w; 
    original.pixelformat := pf24bit; 
    for y := 0 to original.height - 1 do begin 
      p := original.ScanLine[y]; 
      for x := 0 to b3 - 1 do begin 
        arr[z] := p[x]; 
        inc(z); 
      end; 
    end; 
    container.pixelformat := pf32bit; 
    p := container.ScanLine[0]; 
    for x := 0 to w - 1 do 
      p[x * 4 + 3] := arr[x]; 
    z := w; 
    b3 := container.width * 4; 
    for y := 1 to container.height - 1 do begin 
      x := 0; 
      p := container.ScanLine[y]; 
      while x < b3 do begin 
        if z > lg then break; 
        p[x + 3] := arr[z]; 
        inc(x, 4); 
        inc(z); 
      end; 
      if z > lg then break; 
    end; 
    arr := nil; 
  end; 
end; 
 
// Bitmap aus Bitmap herausholen 
 
procedure BMPausBMP(container, neu: TBitmap); 
var 
  arr: array of byte; 
  x, y, z, b3, lg, lk, so: integer; 
  p: PBytearray; 
  kennung, v: string; 
  procedure falsch; 
  begin 
    showmessage('Kein oder zerstörter Container'); 
  end; 
begin 
  kennung := 'BiB'; 
  lk := length(kennung); 
  so := sizeof(integer); 
  if (container.width < lk + so * 2) 
    or (container.pixelformat <> pf32bit) 
    then begin 
    falsch; 
    exit; 
  end; 
  setlength(v, lk); 
  setlength(arr, 2 * so + lk); 
  p := container.ScanLine[0]; 
  for z := 0 to lk + 2 * so - 1 do 
    arr[z] := p[z * 4 + 3]; 
  copymemory(@v[1], @arr[0], lk); 
  if v <> kennung then begin 
    falsch; 
    exit; 
  end; 
  copymemory(@x, @arr[lk], so); 
  copymemory(@y, @arr[lk + so], so); 
  b3 := container.width * 4; 
  neu.pixelformat := pf24bit; 
  neu.width := x; 
  neu.height := y; 
  setlength(arr, x * 3 * y); 
  lg := high(arr); 
  z := 0; 
  for y := 1 to pred(container.height) do begin 
    x := 0; 
    p := container.ScanLine[y]; 
    while x < b3 do begin 
      if z > lg then break; 
      arr[z] := p[x + 3]; 
      inc(x, 4); 
      inc(z); 
    end; 
    if z > lg then break; 
  end; 
  b3 := neu.width * 3 - 1; 
  z := 0; 
  for y := 0 to pred(neu.height) do begin 
    p := neu.scanline[y]; 
    for x := 0 to b3 do begin 
      p[x] := arr[z]; 
      inc(z); 
    end; 
  end; 
  arr := nil; 
end; 
 
// Beispielaufruf 
 
// Bild von Image1 verstecken 
 
procedure TForm1.Button2Click(Sender: TObject); 
var container: TBitmap; 
begin 
  container := TBitmap.create; 
  container.loadfromfile('D:\monalisa.bmp'); 
  BMPinBMP(Image1.Picture.Bitmap, container); 
  container.savetofile('D:\TestContainer.bmp'); 
  container.free; 
end; 
 
// Bild aus Versteck holen 
 
procedure TForm1.Button3Click(Sender: TObject); 
var bmp, container: TBitmap; 
begin 
  bmp := TBitmap.create; 
  container := TBitmap.create; 
  container.loadfromfile('D:\TestContainer.bmp'); 
  BMPausBMP(container, bmp); 
  canvas.draw(15, 170, bmp); // z.B. 
  bmp.free; 
  container.free; 
end;