DBR Delphi-Ecke

					 
// Es wird mit einfachen Mitteln eine Unkenntlichmachung von Strings erreicht. 
// Siehe dazu auch Dateien verschlüsseln.
// Für Textdateien siehe Punkte 8, 9 und 10
  
// 1. String mit Hilfe von Random unter Vermeidung von #0 verschlüsseln 
 
// Getestet mit RS 10.4 unter W11 
 
// Durch Veränderung der Variablen "Value" zwischen 0 und 28.672 kann selbst bei 
// gleichem Passwort ein anderes Ergebnis erzielt werden. 
					

					
					
type  
  Rnd = 0 .. $7000;  
  
var  
  Value: Rnd = 14336; // z.B.  
  
procedure coincidence(PW: string);  
var  
  x, z, v, i: integer;  
begin  
  i := 0;  
  v := 7;  
  for z := 2 to 11 do  
  begin  
    for x := 1 to length(PW) do  
      v := (v * 2 + ord(PW[x]) * z) mod 73;  
    i := i + v mod 10;  
  end;  
  randseed := 17 + i;  
end;  
  
function Crypt(const S, Key: WideString; EnCrypt: Boolean): WideString;  
var  
  i: integer;  
  w, v: Word;  
  procedure makew;  
  begin  
    v := (v + random(99)) and MaxWord;  
    w := w xor random(v);  
  end;  
  procedure en;  
  begin  
    makew;  
    if w = 0 then  
      w := $FFFC;  
  end;  
  procedure de;  
  begin  
    if w = $FFFC then  
      w := 0;  
    makew;  
  end;  
  
begin  
  Setlength(Result, length(S));  
  v := Value + $6789;  
  coincidence(Key);  
  for i := 1 to length(S) do  
  begin  
    w := ord(S[i]);  
    if EnCrypt then  
      en  
    else  
      de;  
    Result[i] := WideChar(w);  
  end;  
end;  
  
  
// Beispiel Verschlüsselung  Memo1 --> Memo2  
procedure TForm1.Button1Click(Sender: TObject);  
begin  
  Memo2.text := Crypt(Memo1.text, 'password', True);  
end;  
  
// Beispiel Entschlüsseln Memo2 selbst  
procedure TForm1.Button2Click(Sender: TObject);  
begin  
  Memo2.text := Crypt(Memo2.text, 'password', False);  
end; 
  
  
//--------------------------------------------------------------------- 
  
// 2. Text mittels Substitution verschlüsseln 
 
// Getestet mit D2010 unter W10 
 
// Eine einfache Art der Verschlüsselung, welche der XOR-Verschlüsselung 
// ähnelt, aber nicht als solche erkennbar ist. 
					

					
					
type  
  art = (Verschluesseln, Entschluesseln);  
  
var  
  TestString: string = '';  
  
function CryptTxt(txt, schlssl: string; like: art): string;  
const  
  z = 31;  
var  
  x, g: Integer;  
  pt, ps, pr: PChar;  
begin  
  result := txt;  
  if txt = '' then  
    exit;  
  pt := @txt[1];  
  ps := @schlssl[1];  
  pr := @result[1];  
  for x := 1 to length(txt) do  
  begin  
    if like = Verschluesseln then  
      g := ord(pt^) + ord(ps^) - z  
    else  
      g := ord(pt^) - ord(ps^) + z;  
    pr^ := chr(g);  
    inc(pt);  
    inc(pr);  
    inc(ps);  
    if ps^ = #0 then  
      ps := @schlssl[1];  
  end;  
end;  
  
// Beispielaufruf  
  
procedure TForm1.Button1Click(Sender: TObject);  
begin  
  RichEdit1.PlainText := True;  
  TestString := CryptTxt(RichEdit1.Text, 'DBR-Delphi', Verschluesseln);  
  RichEdit1.Text := TestString;  
end;  
  
procedure TForm1.Button2Click(Sender: TObject);  
begin  
  RichEdit1.Text := CryptTxt(TestString, 'DBR-Delphi', Entschluesseln);  
end;  
 
 
//--------------------------------------------------------------------- 
 
3.  Erweiterung von 2. 
 
// Getestet mit RS 10.4 unter W11 
 
// Hierbei werden dem Ergebnis Prüfziffern vom Text und vom Passwort 
// übergeben, wobei vorher das Passwort zusätzlich verschleiert wird. 
// Durch Einbeziehung des Zufalls kann der verschlüsselte Text jedesmal 
// anders aussehen. Außerdem wird durch den Wechsel zwischen RawByteString 
// und String das Ergebnis völlig unleserlich. 
 
type  
  C2 = array [0 .. 1] of Char;  
  sls = array [0 .. 19] of Byte;  
  Buch = array [0 .. 223] of Byte;  
  
var  
  SB: Buch;  
  schls: sls;  
  
procedure makeSB(rb: RawByteString; lg: Integer);  
var  
  I: Integer;  
  
  function makeKey(rb: RawByteString; lg: Integer): sls;  
  var  
    I, X: Integer;  
  begin  
    X := 1;  
    for I := 0 to 19 do  
    begin  
      Result[I] := (SB[I] xor ord(rb[X])) and $F7;  
      inc(X);  
      if X > lg then  
        X := 1;  
    end;  
  end;  
  
  procedure Swap(n, M: Byte);  
  var  
    tmp: Byte;  
  begin  
    tmp := SB[n];  
    SB[n] := SB[M];  
    SB[M] := tmp;  
  end;  
  
begin  
  for I := Low(SB) to High(SB) do  
    SB[I] := I + 32;  
  for I := High(SB) downto 0 do  
    Swap(I, random(I));  
  schls := makeKey(rb, lg);  
end;  
  
function hash(const s: string): C2;  
var  
  X, z, erg, lg: Integer;  
  a: ansistring;  
  P: PChar;  
begin  
  a := '';  
  erg := 1;  
  lg := length(s);  
  for z := 2 to 5 do  
  begin  
    for X := 1 to lg do  
      erg := (erg * 2 + ord(s[X]) * (z - ord(odd(X)) * (z - 1))) mod 93;  
    a := a + AnsiChar(erg mod 10);  
  end;  
  P := @a[1];  
  Result[0] := P^;  
  inc(P);  
  Result[1] := P^;  
end;  
  
function CryptTxt(txt: RawByteString; lg: Integer; like: Boolean)  
  : RawByteString;  
const  
  z = 31;  
var  
  X, Y: Integer;  
  g: AnsiChar;  
  pt, pr: PAnsiChar;  
begin  
  Result := txt;  
  pt := @txt[1];  
  pr := @Result[1];  
  Y := 0;  
  for X := 1 to lg do  
  begin  
    if like then  
      g := AnsiChar(ord(pt^) + schls[Y] - z)  
    else  
      g := AnsiChar(ord(pt^) - schls[Y] + z);  
    pr^ := g;  
    inc(pt);  
    inc(pr);  
    inc(Y);  
    if Y > 19 then  
      Y := 0;  
  end;  
end;  
  
function encode(const txt, Passw: String; out erg: String): Byte;  
var  
  Start: Byte;  
  rb: RawByteString;  
  lt, I: Integer;  
  Pc: PChar;  
  C: C2;  
  HT: string;  
begin  
  erg := '';  
  try  
    if txt = '' then  
    begin  
      Result := 1;  
      exit;  
    end;  
    lt := length(Passw);  
    if not(lt in [3 .. 10]) then  
    begin  
      Result := 2;  
      exit;  
    end;  
    C := hash(Passw);  
    HT := hash(txt);  
    Start := GettickCount and $FF;  
    RandSeed := Start;  
    lt := lt * 2;  
    SetLength(rb, lt);  
    CopyMemory(@rb[1], @Passw[1], lt);  
    makeSB(rb, lt);  
    lt := length(txt) * 2;  
    SetLength(rb, lt);  
    CopyMemory(@rb[1], @txt[1], lt);  
    rb := CryptTxt(rb, lt, True);  
    Pc := @rb[1];  
    I := 1;  
    while I < lt do  
    begin  
      erg := erg + Pc^;  
      inc(I, 2);  
      inc(Pc);  
    end;  
    erg := C[0] + Char(Start or $500) + erg + C[1];  
    erg := HT + hash(erg) + erg;  
    Result := 0;  
  except  
    Result := 255;  
  end;  
end;  
  
function decode(const txt, Passw: String; out erg: String): Byte;  
var  
  s, HT: string;  
  Start: Byte;  
  rb: RawByteString;  
  lt, I: Integer;  
  Pc: PChar;  
  C: C2;  
begin  
  erg := '';  
  try  
    lt := length(txt);  
    if lt < 4 then  
    begin  
      Result := 1;  
      exit;  
    end;  
    HT := copy(txt, 1, 2);  
    s := copy(txt, 3, maxint);  
    C[0] := s[1];  
    C[1] := s[2];  
    s := copy(s, 3, maxint);  
    if hash(s) <> C then  
    begin  
      Result := 2;  
      exit;  
    end;  
    lt := length(s);  
    C[0] := s[1];  
    C[1] := s[lt];  
    if C <> hash(Passw) then  
    begin  
      Result := 3;  
      exit;  
    end;  
    s := copy(s, 2, lt - 2);  
    Start := ord(s[1]) and $FF;  
    s := copy(s, 2, maxint);  
    RandSeed := Start;  
    lt := length(Passw) * 2;  
    SetLength(rb, lt);  
    CopyMemory(@rb[1], @Passw[1], lt);  
    makeSB(rb, lt);  
    lt := length(s) * 2;  
    SetLength(rb, lt);  
    CopyMemory(@rb[1], @s[1], lt);  
    rb := CryptTxt(rb, lt, False);  
    s := '';  
    Pc := @rb[1];  
    I := 1;  
    while I < lt do  
    begin  
      s := s + Pc^;  
      inc(I, 2);  
      inc(Pc);  
    end;  
    if HT <> hash(s) then  
    begin  
      Result := 4;  
      exit;  
    end;  
    erg := s;  
    Result := 0;  
  except  
    Result := 255;  
  end;  
end;  
  
  
// Beispielaufrufe:  
  
// Memo1 verschlüsseln...  
procedure TForm1.Button1Click(Sender: TObject);  
var  
  Passwort, s, r: string;  
  b: Byte;  
begin  
  // -------- Nur zum Testen -----------------------------------  
  Memo1.Clear;  
  Memo1.Lines.Add('Das ist ein Versuch: @¾¿?????? ÄÖÜßäöü ???');  
  Passwort := '¿??*12Ä';  
  // -----------------------------------------------------------  
  
  // Passwort := Edit1.Text;  
  
  b := encode(Memo1.Text, Passwort, s);  
  case b of  
    0:  
      begin  
        r := 'OK';  
        Memo1.Text := s;  
      end;  
    1:  
      r := 'Kein Text zum Verschlüsseln gefunden';  
    2:  
      r := 'Passwort muss 3 bis 10 Zeichen haben';  
  else  
    r := 'Unbekannter Fehler';  
  end;  
  ShowMessage(r);  
end;  
  
// ...und wieder entschlüsseln  
procedure TForm1.Button2Click(Sender: TObject);  
var  
  b: Byte;  
  r, s: string;  
begin  
  b := decode(Memo1.Text, '¿??*12Ä', s);  
  case b of  
    0:  
      begin  
        Memo1.Text := s;  
        r := 'OK';  
      end;  
    1:  
      r := 'Kein ordnungsgemäßer Text zum Entschlüsseln gefunden';  
    2:  
      r := 'Dieser Text kann nicht entschlüsselt werden';  
    3:  
      r := 'Sie haben keine Berechtigung';  
    4:  
      r := 'Fehler bei der Entschlüsselung';  
  else  
    r := 'Unbekannter Fehler';  
  end;  
  ShowMessage(r);  
end; 
 
 
 
//--------------------------------------------------------------------- 
  
// 4.Text mittels Tabelle verschlüsseln  
 
// Getestet mit D2010 unter W7  
 
// Eine simple Art der Verschlüsselung. Allerdings kann das Ergebnis über  
// die Häufigkeit der auftretenden Zeichen geknackt werden. Reicht aber allemal  
// aus, Text für andere Computer-User unleserlich zu machen. Die Zeichen in der  
// Tabelle müssen natürlich nicht in der Reihenfolge stehen wie im Beispiel.  
// Logischerweise braucht man für Ver- und Entschlüsselung die gleiche Tabelle.  
// Beim ersten Durchlauf wird verschlüsselt, beim nächsten wieder entschlüsselt. 
  
const  
  Tabelle = #10#32#13#9 +  
    '(+.%ßaÄäBbCcDdEeFfGgHhIiJjKkLlMmNnOoÖöPp=?-/;,!:*' +  
    '"_QqRrSsTtUuÜüVvWwXxYyZz0987654321A)';  
  
function crypt(s: string): string;  
var lg, ltab, stelle, such: integer;  
begin  
  result := s;  
  lg := length(result);  
  if lg = 0 then exit;  
  ltab := length(Tabelle);  
  stelle := 1;  
  while stelle <= lg do begin  
    such := 1;  
    while (Tabelle[such] <> result[stelle]) and (such <= ltab) do inc(such);  
    if such <= ltab then result[stelle] := Tabelle[ltab - such + 1];  
    inc(stelle);  
  end;  
end;  
  
		 
// Beispielaufruf 
  
procedure TForm1.Button3Click(Sender: TObject);  
begin  
  Memo1.text := crypt(Memo1.text);  
end; 

//--------------------------------------------------------------------- 
 
// 5. Text zu Zahlen verschlüsseln 
 
// Getestet mit D2010 unter W7 
 
// Um bei der Verschlüsselung zu vermeiden, dass Steuerzeichen entstehen 
// (z.B. #0 als ungewolltes Stringende oder #13 als ungewollter Zeilenumbruch), 
// werden die bereits verschlüsselten Buchstaben anschließend in eine 
// Zahlenfolge umgewandelt, was man als zusätzliche Verschlüsselung ansehen 
// kann. Allerdings ist der verschlüsselte String dreimal länger als das 
// Original. 

const  
  passwort = '1#-5ab8.*Z1'; // oder sonstwas  
  
var  
  sss: string;  
  
function verschluessele(zuverschluesseln, schluessel: string): string;  
var x, y, lg: integer;  
begin  
  result := '';  
  try  
    if length(zuverschluesseln) > 0 then begin  
      y := 1;  
      lg := length(schluessel);  
      for x := 1 to length(zuverschluesseln) do begin  
        result := result + formatfloat('000', ord(zuverschluesseln[x])  
          xor ord(schluessel[y]));  
        if y = lg then y := 1  
        else inc(y);  
      end;  
    end;  
  except result := ''; end;  
end;  
  
function entschluessele(zuentschluesseln, schluessel: string): string;  
var x, y, lg: integer;  
begin  
  result := '';  
  try  
    lg := length(zuentschluesseln);  
    if (lg > 0) and (lg mod 3 = 0) then begin  
      y := 1;  
      while y < lg do begin  
        result := result + chr(strtoint(copy(zuentschluesseln, y, 3)));  
        inc(y, 3);  
      end;  
      y := 1;  
      lg := length(schluessel);  
      for x := 1 to length(result) do begin  
        result[x] := chr(ord(result[x]) xor ord(schluessel[y]));  
        if y = lg then y := 1  
        else inc(y);  
      end;  
    end;  
  except result := ''; end;  
end;  
  
// Beispielaufruf  
procedure TForm1.Button5Click(Sender: TObject);  
begin  
  sss := verschluessele(Edit1.Text, passwort);  
// showmessage(sss);  
end;  
  
procedure TForm1.Button6Click(Sender: TObject);  
begin  
  sss := entschluessele(sss, passwort);  
// showmessage(sss);  
end; 


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

// 6. Verschlüsselung plus Zufall 
 
// Getestet mit D2010 unter W7 
 
// Der folgende Code arbeitet unter Zuhilfenahme des Zufallsgenerators. 
// Der selbe Text liefert jedesmal ein anderes Teilergebnis, wenn er mit dem 
// selben Schlüssel neu codiertt wird. Der verschlüsselte String wird 
// doppelt so lang wie das Original. 

function verschl(txt, schl: string): string;  
var x, y, lg, n: integer;  
begin  
  result := '';  
  lg := length(schl);  
  y := 1;  
  randomize;  
  for x := 1 to length(txt) do begin  
    n := (byte(txt[x]) xor byte(schl[y])) or  
      (((random(32) shl 8) and 15872) or 16384);  
    if lo(n) < 32 then n := n or 384;  
    if y = lg then y := 1  
    else inc(y);  
    result := result + chr(lo(n)) + chr(hi(n));  
  end;  
end;  
  
function entschl(txt, schl: string): string;  
var x, y, lg, n: integer;  
begin  
  if not odd(length(txt)) then begin  
    result := '';  
    lg := length(schl);  
    y := 1;  
    x := 1;  
    while x < length(txt) do begin  
      n := (byte(txt[x]) or (byte(txt[x + 1]) shl 8));  
      if n and 256 > 0 then n := n and 127  
      else n := n and 255;  
      result := result + chr(n xor byte(schl[y]));  
      if y = lg then y := 1  
      else inc(y);  
      inc(x, 2);  
    end;  
  end else result := txt;  
end;  
  
// Beispielaufruf  
const schlssl = 'h*09mÖ-X#z&5%A@+0';  
  
procedure TForm1.Button1Click(Sender: TObject);  
begin  
  edit1.text := verschl(edit1.text, schlssl);  
end;  
  
procedure TForm1.Button2Click(Sender: TObject);  
begin  
  edit1.text := entschl(edit1.text, schlssl);  
end; 

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


// 7. Variante von "3Z" für Unicode 
 
// Getestet mit D2010 unter Win10 
 
// Simple Variante der XOR-Verschlüsselung.  
// Wenn ein bereits verschlüsselter Text nochmals verschlüsselt wird, 
// kommt es auch hier zu Verlusten. 

function VE3ZX(txt, schl: string; was: boolean): string;  
var  
  i, z, x: integer;  
  a: array [0 .. 2] of integer;  
begin  
  if length(schl) = 3 then  
  begin  
    result := '';  
    z := ord(was) * 2 - 1;  
    x := 0;  
    for i := 0 to 2 do  
      a[i] := ord(schl[i + 1]) - 31;  
    for i := 1 to length(txt) do  
    begin  
      result := result + chr((ord(txt[i]) + a[x] * z));  
      inc(x);  
      if x > 2 then  
        x := 0;  
    end;  
  end  
  else  
    result := txt;  
end;  
  
// Verschlüsseln  
procedure TForm1.Button1Click(Sender: TObject);  
begin  
  Memo1.text := VE3ZX(Memo1.text, 'ö!A', true);  
end;  
  
// Entschlüsseln  
procedure TForm1.Button2Click(Sender: TObject);  
begin  
  Memo1.text := VE3ZX(Memo1.text, 'ö!A', false);  
end; 
 
 //--------------------------------------------------------- 
 
// 8. Textdatei-Verschlüsselung mit Vorbehandlung 
 
// Getestet mit D2010 unter W7 
 
// Hiermit können Texte (Textdateien) verschlüsselt werden, wobei 
// zunächst Buchstabenkombinationen durch Einzelzeichen ersetzt werden. 
// Wichtig ist, dass im Array #10 und #13 an der richtigen Stelle stehen 
// und dass das Array nicht mehr als 31 Elemente hat. 

const  
  min = 1;  
  max = 31;  
  
var  
  pwx: string = '#Mein Passwort#';  
  
  aos: array[min..max] of string =  
  ('heit', 'keit', 'ung', 'le', 'ch', 'be', 'ei', 'em', 'ck', #10,  
    'ie', 'eu', #13, 'tt', 'ff', 'en', 'nn', 'gg', 'eh', 'ne', 'ig',  
    're', 'oh', 'an', 'la', 'mm', 'li', 'ss', 'er', 'au', 'he');  
  
function verschl(txt, schl: string): string;  
var  
  x, y, lg, n: integer;  
begin  
  result := '';  
  if txt = '' then exit;  
  for x := min to max do   
    txt := stringreplace(txt, aos[x], chr(x), [rfreplaceall]);  
  lg := length(schl);  
  y := min;  
  randomize;  
  for x := min to length(txt) do begin  
    n := (byte(txt[x]) xor byte(schl[y])) or  
      (((random(32) shl 8) and 15872) or 16384);  
    if lo(n) < 32 then n := n or 384;  
    if y = lg then y := min  
    else inc(y);  
    result := result + chr(lo(n)) + chr(hi(n));  
  end;  
end;  
  
function entschl(txt, schl: string): string;  
var  
  x, y, lg, n: integer;  
begin  
  result := '';  
  if txt = '' then exit;  
  lg := length(schl);  
  y := min;  
  x := min;  
  while x < length(txt) do begin  
    n := (byte(txt[x]) or (byte(txt[succ(x)]) shl 8));  
    if n and 256 > 0 then n := n and 127  
    else n := n and 255;  
    result := result + chr(n xor byte(schl[y]));  
    if y = lg then y := min  
    else inc(y);  
    inc(x, 2);  
  end;  
  for x := min to max do  
    result := stringreplace(result, chr(x), aos[x], [rfreplaceall]);  
end;  
  
 
// Beispiel:  
  
procedure TForm1.Button1Click(Sender: TObject);  
begin  
  Memo1.lines.loadfromfile('c:\Test.txt');  
end;  
  
procedure TForm1.Button2Click(Sender: TObject);  
begin  
  Memo2.Text := verschl(Memo1.Text, pwx);  
end;  
  
procedure TForm1.Button3Click(Sender: TObject);  
begin  
  Memo3.Text := entschl(Memo2.Text, pwx);  
end; 

//---------------------------------------------------------  
 
// 9. Ganz simple Textdatei-Verschlüsselung 
 
// Getestet mit D2010 unter W7 
 
// Das älteste bekannte militärische Verschlüsselungsverfahren wurde von den Spartanern 
// bereits vor mehr als 2500 Jahren angewendet. Zur Verschlüsselung diente ein (Holz-)Stab 
// mit einem bestimmten Durchmesser (Skytale). Um eine Nachricht zu verfassen, wickelte der 
// Absender einen Streifen wendelförmig um die Skytale, schrieb die Botschaft längs des 
// Stabs auf das Band und wickelte es dann ab. Das Band ohne den Stab wird dem Empfänger 
// überbracht. Fällt das Band in die falschen Hände, so kann die Nachricht nicht gelesen 
// werden, da die Buchstaben scheinbar willkürlich auf dem Band angeordnet sind. Der 
// richtige Empfänger des Bandes konnte die Botschaft mit einer identischen Skytale 
// (einem Stab mit dem gleichen Durchmesser) lesen. Der Durchmesser des Stabes ist somit 
// der geheime Schlüssel bei diesem Verschlüsselungsverfahren. 
// Der Code empfindet das Verfahren nach, wobei die Variable "Diameter" den Stab-Durchmesser 
// repräsentiert und Sender sowie Empfänger bekannt sein muss. Der Wert muss mindestens 
// 2 betragen. 

var  
  Diameter: Word;  
  
function Skytale(const txt: String; out upshot: String): Byte;  
var  
  lg, i, st, x: Integer;  
  hlp, s: string;  
begin  
  try  
    lg := Length(txt);  
    if lg = 0 then  
    begin  
      Result := 1;  
      exit;  
    end;  
    if Diameter > lg div 2 then  
    begin  
      Result := 2;  
      exit;  
    end;  
    if Diameter < 2 then  
    begin  
      Result := 3;  
      exit;  
    end;  
    if odd(lg) then  
    begin  
      s := txt + #32;  
      inc(lg);  
    end  
    else  
      s := txt;  
    upshot := '';  
    st := Diameter;  
    for i := 1 to lg do  
    begin  
      x := ord(s[st]);  
      if x = 255 then  
        x := 31;  
      hlp := chr(x + 1);  
      upshot := upshot + hlp;  
      inc(st, Diameter);  
      if st > lg then  
        st := st - succ(lg);  
      if st < 1 then  
        st := Diameter;  
    end;  
    s := '';  
    Result := 0;  
  except  
    Result := 255;  
  end;  
end;  
  
function SkytaleInterpret(const txt: String; out upshot: String): Byte;  
var  
  lg, st, i, x: Integer;  
begin  
  try  
    lg := Length(txt);  
    if lg = 0 then  
    begin  
      Result := 1;  
      exit;  
    end;  
    if (Diameter > lg div 2) or (Diameter < 2) then  
    begin  
      Result := 2;  
      exit;  
    end;  
    st := Diameter;  
    upshot := txt;  
    for i := 1 to lg do  
    begin  
      x := pred(ord(txt[i]));  
      if x = 31 then  
        x := 255;  
      upshot[st] := chr(x);  
      inc(st, Diameter);  
      if st > lg then  
        st := st - succ(lg);  
      if st < 1 then  
        st := Diameter;  
    end;  
    Result := 0;  
  except  
    Result := 255;  
  end;  
end;  
  
  
// --- Beispielaufrufe ---  
  
// Verschlüsseln  
procedure TForm1.Button1Click(Sender: TObject);  
var  
  s: string;  
  b: Byte;  
begin  
  Screen.Cursor := crHourGlass;  
  Button1.Enabled := False;  
  Application.ProcessMessages;  
  Memo1.Lines.BeginUpdate;  
  // Memo1.Text:='Das ist ein Test';  
  Memo1.Lines.LoadFromFile('C:\test.txt');  
  
  Diameter := 7; // z.B.  
  
  b := Skytale(Memo1.Text, s);  
  case b of  
    0:  
      Memo1.Text := s;  
    1:  
      Memo1.Text := 'Keinen Text zum Verschlüsseln gefunden';  
    2:  
      Memo1.Text := 'Diameter im Verhältnis zum Text zu groß';  
    3:  
      Memo1.Text := 'Diameter muss mindestens 2 sein';  
    else  
      Memo1.Text := 'Unerwarteter Fehler';  
    end;  
  s := '';  
  Memo1.Lines.EndUpdate;  
  Screen.Cursor := crDefault;  
  Button1.Enabled := True;  
end;  
  
// Entschlüsseln  
procedure TForm1.Button2Click(Sender: TObject);  
var  
  b: Byte;  
  s: string;  
begin  
  Button2.Enabled := False;  
  Application.ProcessMessages;  
  
  Diameter := 7;  
  
  b := SkytaleInterpret(Memo1.Text, s);  
  case b of  
    0:  
      Memo2.Text := s;  
    1:  
      Memo2.Text := 'Keinen Text zum Entschlüsseln gefunden';  
    2:  
      Memo2.Text := 'Falscher Wert für Diameter';  
    else  
      Memo2.Text := 'Unerwarteter Fehler';  
    end;  
  s := '';  
  Button2.Enabled := True;  
end;


//---------------------------------------------------------  
 
// 10. Textdatei-Verschlüsselung mit Datum und Prüfsumme 
 
// Getestet mit Delphi 10.4 unter W11 
 
// Im Ursprungsschreiben muss ein Datum abgebildet sein, welches dann automatisch ermittelt
// wird. Dieses Datum muss dem Empfänger bekannt sein, denn er muss es vor dem Entschlüsseln
// in Edit2 Eingeben. In Edit1 muss von beiden ein Zahlen-Key zwischen 123 und 123456 eingegeben
// werden, der aus Sicherheitsgründen keine Nullen und direkt nebeneinander keine doppelte Ziffern 
// enhalten darf. Auf der Form befinden sich 1 TRichEdit, 3 TButton und 2 TEdit.

type 
  Rng = 123 .. 123456; // Rechengrundlage für diesen Code 
 
const 
  LG = 7; // mehrfach nötig 
 
var 
  Pass: Rng; // Key: kommt aus Edit1 
  Src: String = 'D:\Test.txt'; // Beispiel: Text mit einem Datum 
  Dst: String = 'D:\Versch.txt'; // Ziel der verschlüsselten Datei 
 
function Crypt(txt, schlssl: Unicodestring; like: Boolean): Unicodestring; 
const 
  z = 31; 
var 
  x, g: Integer; 
  pt, ps, pr: PWideChar; 
begin 
  result := txt; 
  if txt = '' then 
    exit; 
  pt := @txt[1]; 
  ps := @schlssl[1]; 
  pr := @result[1]; 
  for x := 1 to length(txt) do 
  begin 
    if like then 
      g := ord(pt^) + ord(ps^) - z 
    else 
      g := ord(pt^) - ord(ps^) + z; 
    pr^ := Widechar(g); 
    inc(pt); 
    inc(pr); 
    inc(ps); 
    if ps^ = #0 then 
      ps := @schlssl[1]; 
  end; 
end; 
 
function schl(const s: Unicodestring; Laenge: Integer): Unicodestring; 
var 
  x, z, erg: Integer; 
begin 
  erg := 1; 
  result := ''; 
  for z := 2 to succ(Laenge) do 
  begin 
    for x := 1 to length(s) do 
      erg := (erg * 2 + ord(s[x]) * (z - ord(odd(x)) * (z - 1))) mod 97; 
    result := result + inttostr(erg mod 10) 
  end; 
end; 
 
function Rechnen(dt: TDate; pw: Integer): Unicodestring; 
var 
  H: Double; 
begin 
  H := dt * pw; // z.B. 
  result := schl(formatfloat('#', H), LG); 
end; 
 
function Datum(SL: TStrings; out dt: TDate): Byte; 
var 
  s, txt: String; 
  y: Integer; 
 
  function Zahl(C: String): Boolean; 
  begin 
    result := CharInSet(C[1], ['0' .. '9']); 
  end; 
 
  function Nullen: Boolean; 
  var 
    i: Integer; 
  begin 
    result := False; 
    for i := 1 to length(s) do 
      if s[i] = '0' then 
      begin 
        result := True; 
        Break; 
      end; 
  end; 
 
  function gleiche: Boolean; 
  var 
    i: Integer; 
  begin 
    result := False; 
    for i := 1 to pred(length(s)) do 
      if s[i] = s[succ(i)] then 
      begin 
        result := True; 
        Break; 
      end; 
  end; 
 
begin 
  s := inttostr(Pass); 
 
  if Nullen then 
  begin 
    result := 1; 
    exit; 
  end; 
 
  if gleiche then 
  begin 
    result := 2; 
    exit; 
  end; 
 
  Try 
    // erste vorhandene Datum finden 
    for y := 1 to SL.count do 
    begin 
      txt := Trim(SL[y]); 
      if txt = '' then 
        continue; 
      while not Zahl(txt[1]) do 
        txt := copy(txt, 2, MaxInt); 
      while not Zahl(copy(txt, length(txt), 1)) do 
        txt := copy(txt, 1, pred(length(txt))); 
      try 
        dt := VarToDateTime(Trim(txt)); 
        if (dt >= 36892) and (dt <= 2958465) then 
          Break; 
      except 
      end; 
    end; 
    result := 0; 
  except 
    result := 255; 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  with RichEdit1 do 
  begin 
    Text := ''; 
    ScrollBars := ssBoth; 
  end; 
end; 
 
function PassTest(s: String; out i: Integer): Boolean; 
begin 
  i := StrTointDef(s, -1); 
  if (i < Low(Rng)) or (i > High(Rng)) then 
  begin 
    showmessage('Key konnte nicht aufgelöst werden'); 
    result := False; 
  end 
  else 
    result := True; 
end; 
 
// Text laden bzw. erzeugen 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  RichEdit1.Lines.LoadFromFile(Src); 
  // oder Text (mit Datum) eintippen 
end; 
 
// Verschlüsseln ********************** 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  D: TDate; 
  i: Integer; 
  p, s: Unicodestring; 
begin 
  // Key in Edit1 eingeben 
  if not PassTest(Edit1.Text, i) then 
    exit; 
  Pass := i; 
  // Datum aus Text holen 
  i := Datum(RichEdit1.Lines, D); 
  case i of 
    0: 
      begin 
        Screen.Cursor := crHourGlass; 
        p := Rechnen(D, Pass); 
        s := schl(Trim(RichEdit1.Text), LG); 
        s := Crypt(s, p, True); 
        RichEdit1.Text := Crypt(RichEdit1.Text, p, True); 
        RichEdit1.Text := s + RichEdit1.Text; 
        // Speichern 
        RichEdit1.Lines.Savetofile(Dst); 
        Screen.Cursor := crDefault; 
      end; 
    1: 
      showmessage('Key enthält Nullen'); 
    2: 
      showmessage('Gleiche Ziffern im Key nebeneinander'); 
    255: 
      showmessage('Datum konnte nicht ermittelt werden'); 
  end; 
end; 
 
// Entschlüsseln ********************** 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  D: TDate; 
  p, s: Unicodestring; 
  i: Integer; 
begin 
  try 
    // Datum in Edit2 eingeben 
     D := VarToDateTime(Edit2.Text); 
  except 
    showmessage('Datum nicht erkannt'); 
    exit; 
  end; 
  // Key in Edit1 eingeben 
  if not PassTest(Edit1.Text, i) then 
    exit; 
  Pass := i; 
  // Laden 
  if not FileExists(Dst) then 
    showmessage('Datei nicht gefunden') 
  else 
  begin 
    Screen.Cursor := crHourGlass; 
    RichEdit1.Lines.LoadFromFile(Dst); 
    p := Rechnen(D, Pass); 
    s := copy(RichEdit1.Text, 1, LG); 
    s := Crypt(s, p, False); 
    RichEdit1.Text := copy(RichEdit1.Text, 8, MaxInt); 
    RichEdit1.Text := Crypt(RichEdit1.Text, p, False); 
    p := schl(Trim(RichEdit1.Text), LG); 
    Screen.Cursor := crDefault; 
    if p <> s then 
    begin 
      RichEdit1.Text := ''; 
      showmessage('Datei ungültig'); 
    end; 
  end; 
end;

					

					 
 
Zugriffe seit 6.9.2001 auf Delphi-Ecke