DBR Delphi-Ecke

// Hiermit kann man einen kurzen Text in Bildern verstecken (Steganografie).

// Getestet mit D4 unter XP

// Variante 1:
// Text wird einfach hinten an ein Bild angehängt. Ich benutze hier Klartext,
// welcher aber besser verschlüsselt werden sollte. Wird das Bild bearbeitet,
// geht die Informationt verloren.

uses JPeg; 
 
function JPAnhang(jp: TJpegImage; ziel: string; st: TStrings): boolean; 
var 
  ms: TMemorystream; 
  lg: integer; 
begin 
  result := false; 
  try 
    ms := TMemorystream.create; 
    jp.savetostream(ms); 
    lg := length(st.text); 
    ms.writebuffer(st.text[1], lg); 
    ms.writebuffer(lg, 4); 
    ms.SaveToFile(ziel); 
    ms.free; 
  except 
    exit; 
  end; 
  result := true; 
end; 
 

function JPAuslesen(jp: TJpegImage): string; 
var 
  ms: TMemorystream; 
  lg: integer; 
begin 
  result := ''; 
  ms := TMemorystream.create; 
  try 
    jp.savetostream(ms); 
    ms.Seek(-4, sofromend); 
    ms.readbuffer(lg, 4); 
    setlength(result, lg); 
    ms.Seek(-lg - 4, sofromend); 
    ms.readbuffer(result[1], lg); 
    ms.free; 
  except 
    ms.free; 
  end; 
end;


// Beispielaufruf: 
 
// Text verstecken 
 
procedure TForm1.Button4Click(Sender: TObject); 
var 
  jp: TJpegImage; 
begin 
  jp := TJpegImage.create; 
  jp.loadfromfile('c:\vogel.jpg'); 
  canvas.draw(500, 10, jp); 
  if not JPAnhang(jp, 'c:\versteck.jpg', Memo1.Lines) 
    then showmessage('FEHLER') else begin 
    jp.loadfromfile('c:\versteck.jpg'); 
    canvas.draw(500 + jp.width + 5, 10, jp); // Kontrolle 
  end; 
end; 
 
 
// Text auslesen 
 
procedure TForm1.Button5Click(Sender: TObject); 
var 
  sl: TStringlist; 
  jp: TJPegImage; 
begin 
  sl := TStringlist.create; 
  jp := TJpegImage.create; 
  jp.loadfromfile('c:\versteck.jpg'); 
  sl.text := JPAuslesen(jp); 
  showmessage(sl.text); 
  sl.free; 
  jp.free; 
end;

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

// Variante 2:
// Hiermit kann man einen kurzen Text in den Farbinformationen einer Bitmap
// mit 24 Bit Farbtiefe unterbringen ohne dass man einen Unterschied zum
// Original sehen kann und ohne dass man das Original zum entschlüsseln braucht.
// Bei Veränderung des codierten Bildes, wie z.B. Aufhellung, Kontrast-
// steigerung oder Änderung des Pixelformates, gehen die Informationen
// verloren.

function einsetzen(bm: TBitmap; const txt: TStrings): boolean; 
var 
  i, x, y, z, b3, lg: integer; 
  p: PBytearray; 
  mask: byte; 
  s: string; 
begin 
  Result := false; 
  if (txt.Text = '') or 
    (bm.pixelformat <> pf24bit) then exit; 
  lg := length(txt.Text); 
  s := inttohex(lg, 4) + txt.Text; 
  inc(lg, 4); 
  if lg * 8 > bm.height * bm.width then exit; // Text zu lang 
  b3 := bm.width * 3; 
  mask := 1; 
  z := 1; 
  i := 0; 
  try 
    for y := 0 to bm.height - 1 do begin 
      p := bm.scanline[y]; 
      x := 0; 
      while x < b3 do begin 
        if z = succ(lg) then begin 
          Result := true; 
          exit; 
        end; 
        p[x + 1] := p[x + 1] and $FE or ((ord(s[z]) and mask) shr i); 
        inc(i); 
        if i = 8 then begin 
          inc(z); 
          i := 0; 
          mask := 1; 
        end else 
          mask := mask shl 1; 
        inc(x, 3); 
      end; 
    end; 
  except end; 
end; 
 
 
function auslesen(bm: TBitmap): string; 
var 
  i, x, y, z, m, b3: integer; 
  p: PBytearray; 
  c: byte; 
  s: string; 
begin 
  result := ''; 
  if (bm.pixelformat <> pf24bit) 
    then exit; 
  s := ''; 
  m := maxint; 
  b3 := bm.width * 3; 
  z := 1; 
  i := 0; 
  c := 0; 
  try 
    for y := 0 to bm.height - 1 do begin 
      p := bm.scanline[y]; 
      x := 0; 
      while x < b3 do begin 
        if i = 8 then begin 
          if m = 0 then exit; 
          i := 0; 
          if z < 5 then begin 
            inc(z); 
            s := s + chr(c); 
            if z = 5 then 
              m := strtoint('$' + s); 
          end else begin 
            result := result + chr(c); 
            dec(m); 
          end; 
          c := 0; 
        end; 
        c := c or ((p[x + 1] and 1) shl i); 
        inc(i); 
        inc(x, 3); 
      end; 
    end; 
  except end; 
end; 
 
 
// Beispielaufruf: 
 
 
// Text verstecken 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  bm.loadfromfile('c:\frau.bmp'); 
  bm.pixelformat := pf24bit; 
  canvas.draw(500, 10, bm); 
  if not einsetzen(bm, Memo1.Lines) 
    then showmessage('FEHLER') 
  else begin 
    canvas.draw(500 + bm.width + 5, 10, bm); // Kontrolle 
    bm.savetofile('c:\versteck.bmp'); 
  end; 
  bm.free; 
end; 
 
// Text auslesen 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  sl: TStringlist; 
  bm: TBitmap; 
begin 
  sl := TStringlist.create; 
  bm := TBitmap.create; 
  bm.loadfromfile('c:\versteck.bmp'); 
  bm.pixelformat := pf24bit; 
  sl.text := auslesen(bm); 
  showmessage(sl.text); 
  sl.free; 
  bm.free; 
end;

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

// Variante 2.1:
// Hiermit kann man die dreifache Menge an Text unterbringen als bei der
// vorigen Variante. Allerdings ist statistisch eher nachweisbar, dass Text
// im Bild versteckt ist.

function einsetzenX(bm: TBitmap; const txt: TStrings): boolean; 
var 
  i, k, x, y, z, b3, lg: integer; 
  p: PBytearray; 
  mask: byte; 
  s: string; 
  function weiter: boolean; 
  begin 
    inc(i); 
    if i = 8 then begin 
      inc(z); 
      if z = succ(lg) then begin 
        Result := true; 
        exit; 
      end; 
      i := 0; 
      mask := 1; 
    end else 
      mask := mask shl 1; 
    Result := false; 
  end; 
begin 
  Result := false; 
  if (txt.Text = '') or 
    (bm.pixelformat <> pf24bit) then exit; 
  lg := length(txt.Text); 
  s := inttohex(lg, 4) + txt.Text; 
  inc(lg, 4); 
  b3 := bm.width * 3; 
  mask := 1; 
  z := 1; 
  i := 0; 
  try 
    for y := 0 to bm.height - 1 do begin 
      p := bm.scanline[y]; 
      x := 0; 
      while x < b3 do begin 
        for k := 0 to 2 do begin 
          p[x + k] := p[x + k] and $FE or ((ord(s[z]) and mask) shr i); 
          if weiter then begin 
            Result := true; 
            exit; 
          end; 
        end; 
        inc(x, 3); 
      end; 
    end; 
  except end; 
end; 
 
 
function auslesenX(bm: TBitmap): string; 
var 
  i, k, x, y, z, m, b3: integer; 
  p: PBytearray; 
  c: byte; 
  s: string; 
begin 
  result := ''; 
  if (bm.pixelformat <> pf24bit) 
    then exit; 
  s := ''; 
  m := maxint; 
  b3 := bm.width * 3; 
  z := 1; 
  i := 0; 
  c := 0; 
  try 
    for y := 0 to bm.height - 1 do begin 
      p := bm.scanline[y]; 
      x := 0; 
      while x < b3 do begin 
        for k := 0 to 2 do begin 
          if i = 8 then begin 
            if m = 0 then exit; 
            i := 0; 
            if z < 5 then begin 
              inc(z); 
              s := s + chr(c); 
              if z = 5 then 
                m := strtoint('$' + s); 
            end else begin 
              result := result + chr(c); 
              dec(m); 
            end; 
            c := 0; 
          end; 
          c := c or ((p[x + k] and 1) shl i); 
          inc(i); 
        end; 
        inc(x, 3); 
      end; 
    end; 
  except end; 
end; 
 
 
// Beispielaufruf: 
 
 
// Text verstecken 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  bm.loadfromfile('c:\frau.bmp'); 
  bm.pixelformat := pf24bit; 
  canvas.draw(500, 10, bm); 
  if not einsetzenX(bm, Memo1.Lines) 
    then showmessage('FEHLER') 
  else begin 
    canvas.draw(500 + bm.width + 5, 10, bm); // Kontrolle 
    bm.savetofile('c:\versteck.bmp'); 
  end; 
  bm.free; 
end; 
 
// Text auslesen 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  sl: TStringlist; 
  bm: TBitmap; 
begin 
  sl := TStringlist.create; 
  bm := TBitmap.create; 
  bm.loadfromfile('c:\versteck.bmp'); 
  bm.pixelformat := pf24bit; 
  sl.text := auslesenX(bm); 
  showmessage(sl.text); 
  sl.free; 
  bm.free; 
end;

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

// Variante 3:
// Hiermit kann man einen kurzen Text in den Pixeln einer Bitmap mit 32 Bit
// Farbtiefe unterbringen ohne dass eine Farbinformation geändert wird. Es
// wird einfach das vierte Bit (alpha-Bit) eines Pixels belegt. Allerdings
// geht das nur, wenn kein Alpha-Blendung genutzt wird. Bei Bearbeitung des
// Bildes geht die Information verloren.

function einsetzen32(bm: TBitmap; const txt: TStrings): boolean; 
var 
  x, y, z, b4: integer; 
  p: PBytearray; 
begin 
  Result := false; 
  if (txt.Text = '') or 
    (bm.pixelformat <> pf32bit) then exit; 
  b4 := bm.width * 4; 
  z := 1; 
  try 
    for y := 0 to bm.height - 1 do begin 
      p := bm.scanline[y]; 
      x := 0; 
      while x < b4 do begin 
        if txt.text[z] = #0 then begin 
          p[x + 3] := 0; 
          Result := true; 
          exit; 
        end else 
          p[x + 3] := ord(txt.text[z]) xor 1; 
        inc(z); 
        inc(x, 4); 
      end; 
    end; 
  except end; 
end; 
 

function auslesen32(bm: TBitmap): string; 
var 
  x, y, b4: integer; 
  p: PBytearray; 
begin 
  result := ''; 
  if bm.pixelformat <> pf32bit then exit; 
  b4 := bm.width * 4; 
  try 
    for y := 0 to bm.height - 1 do begin 
      p := bm.scanline[y]; 
      x := 0; 
      while x < b4 do begin 
        if p[x + 3] = 0 then exit; 
        result := result + chr(p[x + 3] xor 1); 
        inc(x, 4); 
      end; 
    end; 
  except end; 
end; 
 
 
// Beispielaufruf: 
  
 
// Text verstecken  
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  bm.loadfromfile('c:\frau.bmp'); 
  bm.pixelformat := pf32bit; 
  canvas.draw(500, 10, bm); 
  if not einsetzen32(bm, Memo1.Lines) 
    then showmessage('FEHLER') 
  else begin 
    canvas.draw(500 + bm.width + 5, 10, bm); // Kontrolle
    bm.savetofile('c:\versteck.bmp'); 
  end; 
  bm.free; 
end; 
 
 
// Text auslesen 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  sl: TStringlist; 
  bm: TBitmap; 
begin 
  sl := TStringlist.create; 
  bm := TBitmap.create; 
  bm.loadfromfile('c:\versteck.bmp'); 
  bm.pixelformat := pf32bit; 
  sl.text := auslesen32(bm); 
  showmessage(sl.text); 
  sl.free; 
  bm.free; 
end;