Joachim Mohr   Mathematik Musik Delphi
//
//JPG-Bild als Stringkonstante speichern.
//Kopiere den Text und füge ihn in Deinen Delphi-Editor ein.
//Speichere ihn dann als "unit2.pas" ab.
unit Unit2;
interface
Procedure BinaerStrToTextStr(const b:string; var strtext, str01:string; kurz:boolean);
function TextStrToBinaerst(const t,s01:string; kurz: boolean): string;
procedure LiesDiBinaerdateiInDasClipboardein;
implementation
uses classes, dialogs, sysutils, Clipbrd, unit1;
//Die zwei wichtigsten Funktionen
Procedure BinaerStrToTextStr(const b:string; var strtext, str01:string; kurz:boolean);
    const Hub = 40; //Oberhalb #39 (Hochkomma)
    var k:integer;
  function NullEinsStrgZuTextstr(const s01:string): string;
     //Jeweils 7 Bytes - zum Beispiel - "0011000" wird in ein "lesbares" Byte übergeführt
    var k,j: integer;
        a: string;
    function NullEinsZuChar(const s:string): char; //zum Beispiel s='0011000';
      var j,n: byte;
    begin //geht auch kürzer mit "shr" und "and" ("Maschinennaher Code").
      n := 0;
      for j := 1 to 7 do
        if (j «=length(s)) and (s[j] = '1') then
          Case j of 7: n := n + 1;
                    6: n := n + 2;
                    5: n := n + 4;
                    4: n := n + 8;
                    3: n := n + 16;
                    2: n := n + 32;
                    1: n := n + 64;
          End; //n maximal 127
      if n « Hub then n := n + 128; //So wird ein "unlesbares" Char "lesbar"
      result := char(n)
    end;
  begin
    setlength(a,7);
    setlength(result,length(s01) div 7+1);
    k := 0;
    while k «= length(s01) do Begin
      for j := 1 to 7 do
        if (k + j «=length(s01)) and (s01[k+j] = '1')
          then a[j] := '1' else a[j] := '0';
      inc(k,7);
      result[k div 7] := NullEinsZuChar(a);
    End;
  end;
begin
  setlength(strtext,length(b)); // strtext := stringtest + «irgend ein Zeichen» kostet zu viel Zeit
  setlength(str01,length(b));   // Deswegen wird gleich zu Anfang Speicherplatz reserviert
  for k := 1 to length(b) do
     if ord(b[k]) »= Hub then Begin
        strtext[k] := b[k];
        str01[k] := '0';
     End else Begin
        strtext[k] := char(ord(b[k]) + Hub); //Nicht "lesbares" Char wird "lesbar".
        str01[k] := '1';                     //Das muss man sich merken "0" oder "1"
     End;
  if kurz then str01 := NullEinsStrgZuTextstr(str01);
end;
function TextStrToBinaerst(const t,s01:string; kurz: boolean): string;
  const Hub = 40; //Oberhalb Hochkomma
  var k:integer;
      s01echtausNullEins: string;
  function TextStrZuNullEinsStr(const t:string): string;
      var k: integer;
    function CharZuNullEins(const c:char): string; //geht auch "maschinennäher"
      var k,n: integer;
    begin
      setlength(result,7);
      n := ord(c);
      if n »=128 then n := n - 128; //Das war ursprünglich ein "unlesbares" Char.
      for k := 1 to 7 do
        Case k of 7: if n and 1 = 1 then result[k] := '1' else result[k] := '0';
                  6: if n and 2 = 2 then result[k] := '1' else result[k] := '0';
                  5: if n and 4 = 4 then result[k] := '1' else result[k] := '0';
                  4: if n and 8 = 8 then result[k] := '1' else result[k] := '0';
                  3: if n and 16 = 16 then result[k] := '1' else result[k] := '0';
                  2: if n and 32 = 32 then result[k] := '1' else result[k] := '0';
                  1: if n and 64 = 64 then result[k] := '1' else result[k] := '0';
        End;
    end;
  begin
    result := '';
    for k := 1 to length(t) do result := result + CharZuNullEins(t[k]);
  end;
begin
  if kurz then s01echtausNullEins := TextStrZuNullEinsstr(s01) else
    s01echtausNullEins := s01;
  setlength(result,length(t));
  for k := 1 to length(t) do
     if s01echtausNullEins[k] = '0' then result[k] := t[k] else
       result[k] := char(ord(t[k]) - Hub);
end;
//Ende der zwei wichtigsten Funktionen
//Folgende Prozeduren dienen dazu, eine Binärdatei als
//Textdatei in das Clipboard zu kopieren
//Nach dem Einbinden der Ressource als Konstanten werden sie nicht mehr gebraucht
function pfad: string;
begin
  with form1.opendialog1 do
    if execute then pfad := filename else pfad := '';
end;
function FileToBinaerStr(const pfad: string): string; //String als Puffer für die Bytes
var
  F: TStream;
begin
  F := TFileStream.Create(pfad, fmOpenRead or fmShareDenyWrite);
  try
    SetLength(result, F.Size);
    F.ReadBuffer(PChar(result)^, F.Size);
  finally
    F.Free;
  end;
end;
procedure LiesDiBinaerdateiInDasClipboardein;
  const HK = '''';  //Hochkomma
  var binaerstr,strtext,str01: string;
      k: integer;
      sl: Tstringlist;
begin
  binaerstr := FileToBinaerStr(pfad);
  binaerstrToTextStr(binaerstr,strtext,str01,true);
  sl := Tstringlist.create;
  try
    sl.text :='const strtext = ';
    k := 1;
    while k « length(strtext) do Begin
      sl.add(HK + copy(strtext,k,80) + HK + '+');
      k := k + 80;
    End;
    sl.Text := copy(sl.Text,1,length(sl.text) - 4) + HK + ';'#13#10+#13#10 + 's01 = ';
    k := 1;
    while k « length(str01) do Begin
      sl.Add(HK + copy(str01,k,80) + HK + '+');
      k := k +80;
    End;
    sl.Text := copy(sl.Text,1,length(sl.text) - 4) + HK+ ';';
    clipboard.astext := sl.text;
  finally sl.free End;
end;
end.