Text aus Bild auslesen

[TobiTomate]

Moin Moin!

Ich habs zusammen mit einer Mitschülerin hinbekommen.

Hier der komplette Quellcode(fast ganz unten ist die Prozedure zum Auslesen):

Delphi-Quellcode:

var
  Form1: TForm1;
  eingabeT, binT, ausgabeT : string; //Eingabetext, Binärtext, Ausgabetext

implementation

{$R *.dfm}

function CharToBin(Buchstabe : char): string; //Buchstabe -> Binärcode
var
  I: Integer;
begin
  SetLength(result, 8);
  for I := 1 to 8 do
  begin
    if (Byte(Buchstabe) shr (8-i)) and 1 = 0 then
      result[i] := '0'
    else
      result[i] := '1';
  end;
end;

function BinToChar(Ziffer : string): string; //Binärcode -> Buchstabe
var Buchstabe : integer;
begin
  Buchstabe:= (StrToInt(Ziffer[1]) * 128) + (StrToInt(Ziffer[2]) * 64) +
              (StrToInt(Ziffer[3]) * 32)  + (StrToInt(Ziffer[4]) * 16) +
              (StrToInt(Ziffer[5]) * 8)   + (StrToInt(Ziffer[6]) * 4)  +
              (StrToInt(Ziffer[7]) * 2)   + (StrToInt(Ziffer[8]) * 1); //Addition aller Potenzen
  result:=chr(Buchstabe);
end;

function DezToBin(Zahl : Integer): string; //Dezimalzahl -> Binärcode
var
  I: Integer;
begin
  SetLength(result, 8);
  for I := 1 to 8 do
  begin
    if (Byte(Zahl) shr (8-i)) and 1 = 0 then
      result[i] := '0'
    else
      result[i] := '1';
  end;
end;

procedure TForm1.Button1Click(Sender: TObject); //.txt Datei öffnen
begin
if OpenTextFileDialog1.Execute then
Memo1.Lines.LoadFromFile(OpenTextFileDialog1.FileName);
end;

procedure TForm1.Button2Click(Sender: TObject); //Leerzeichen entfernen
begin
Memo1.Text:=StringReplace(Memo1.Text,' ','',[rfReplaceAll]);
end;

procedure TForm1.Button3Click(Sender: TObject); //Eingabetext umwandeln
var I, eingabeL : integer; //eingabeL = Länge des Eingabetextes
begin
Memo2.Clear;
eingabeT:=Memo1.Text;
eingabeL:=Length(Memo1.Text);
binT:='';
for I := 1 to eingabeL do
  begin
    binT:= binT + CharToBin(eingabeT[I]);
  end;
binT:= binT + '00000100'; //Abbruchbedingung anhängen
while length(binT) mod 3 <> 0 do //Prüfen, ob durch 3 teilbar
binT:= binT + '0';
Memo2.Lines.Add(binT);
end;

procedure TForm1.Button4Click(Sender: TObject); //Binärtext speichern
begin
if SaveTextFileDialog1.Execute then
Memo2.Lines.SaveToFile(SaveTextFileDialog1.FileName+'.txt');
end;

procedure TForm1.Button5Click(Sender: TObject); //Programm schließen
begin
close;
end;

procedure TForm1.Button6Click(Sender: TObject);
begin
if OpenPictureDialog1.Execute then
Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
end;

procedure TForm1.Button7Click(Sender: TObject); //Text im Bild verstecken
var Kx,Ky : integer; // Kx/Ky = Koordinate x/y
    farbe : longint;
    R,G,B : byte;
begin
  for Ky := 0 to Image1.Picture.Height - 1 do
    begin
      for Kx := 0 to Image1.Picture.Width - 1 do
        begin  
          if binT <> '' then
          begin
            farbe:= colortorgb(Image1.Canvas.Pixels[Kx,Ky]); //Farbwerte des Pixels auslesen
            R:= GetRValue(farbe); //Rotwert auslesen
            G:= GetGValue(farbe); //Grünwert auslesen
            B:= GetBValue(farbe); //Blauwert auslesen
            R:= R shr 1 shl 1;          //letztes Bit auf 0 setzten
            R:= R + StrToInt(binT[1]);  //erstes Bit des Binärcodes anhängen
            G:= G shr 1 shl 1;
            G:= G + StrToInt(binT[2]);  //zweites Bit des Binärcodes anhängen
            B:= B shr 1 shl 1;
            B:= B + StrToInt(binT[3]);  //drittes Bit des Binärcodes anhängen
            Image1.Canvas.Pixels[Kx,Ky]:=RGB(R,G,B); //neue Werte in Pixel schreiben und Text verstecken
            Delete(binT,1,3);
          end
          else
            exit;
        end;
    end;
end;

procedure TForm1.Button8Click(Sender: TObject);
begin
if SavePictureDialog1.Execute then
Image1.Picture.SaveToFile(SavePictureDialog1.FileName+'.bmp');
end;

procedure TForm1.Button9Click(Sender: TObject);
var Kx,Ky : integer; // Kx/Ky = Koordinate x/y
    farbe : longint;
    R,G,B : byte;
    RBin,GBin,BBin,Buchst,binär : string;
begin
  for Ky := 0 to Image1.Picture.Height - 1 do
    begin
      for Kx := 0 to Image1.Picture.Width - 1 do
        begin
          farbe := colortorgb(Image1.Canvas.Pixels[Kx, Ky]); //Farbwerte des Pixels auslesen
            R:=getRvalue(farbe); //Rotwert auslesen
            G:=getGvalue(farbe); //Grünwert auslesen
            B:=getBvalue(farbe); //Blauwert auslesen
            RBin:=DezToBin(R); //Rotwert wird in von Dezimal zu Binär umgewandelt
            GBin:=DezToBin(G); //Grünwert wird in von Dezimal zu Binär umgewandelt
            BBin:=DezToBin(B); //Blauwert wird in von Dezimal zu Binär umgewandelt
            binär:=binär+RBin[8]; //letztes Zeichen des Codes hinzufügen
            binär:=binär+GBin[8];
            binär:=binär+BBin[8];
          if length(binär) > 7 then //sobald Zeichenkette länger als 7 Zeichen ist .... 
      begin                       
        Buchst := copy(binär, 1, 8); //wird diese übernommen                    <-------
        if Buchst = '00000100' then
              begin
                Memo3.Lines.Add(ausgabeT); //Ausgabe der Zeichenkette
                exit;
              end;
      ausgabeT := ausgabeT + BinToChar(Buchst); //Erstellung der Zeichenkette
      delete(binär,1,8);            //Leeren der Hilfvariable binär
      end;
        end;
    end;
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Clear;
Memo2.Clear;
end;

end.