DBR Delphi-Ecke

// Es wird mit einfachen Mitteln eine Verschlüsselung von Strings erreicht.
// Siehe dazu auch Dateien verschlüsseln
// Für Textdateien aber siehe unten Punkt 10, Punkt 11 und Punkt 12

// 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;

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

// 1.1 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; 


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

1.2  Wesentliche Erweiterung von 1.1

// 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;




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

// 2.Text mittels Tabelle verschlüsseln 

// Getestet mit D4 unter Win98 und 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;
      	

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

// 3. Verschlüsselungsmethode "V128"
// (siehe auch 3a. für Widestrings)

// In dieser Form nur für D4 unter Win98

// Hier handelt es sich wieder um eine Tabellen-Verschlüsselung.
// Allerdings ist die Häufigkeit einzelner Buchstaben nicht mehr auszumachen.
// Die Methode ist direkt abgeleitet von der Base64-Codierung, arbeitet aber
// via Zufallsgenerator mit zwei unterschiedlichen Tabellen. Somit hat man eine
// höhere Verschlüsselungsrate und dem verschlüsselten Text ist nicht
// anzusehen, dass eigentlich nur 64 Zeichen verwendet wurden. Die Tabellen
// kann (ja sollte) man sich selbst aufbauen. Da aber nicht alle Zeichen
// enthalten sein dürfen, kann man mit der Funktion "TabelleOK" zunächst die
// Zeichen überprüfen. Der verschlüsselte Text ist länger als das Original.

        const 
 Tab1 = 
  '4F2!"#N$%(S+/1,Ñ' + 
  '7Æ8:0;<M=>?@A«Cu' + 
  'KgTG9EH)I-L*OØQP' + 
  'UVèX[Ya£bcÙdehij'; 
 Tab2 = 
  'tÞkÌnpÐqr¬yzÖÇÜs' + 
  '¤äf.×\]{D|Z}l~¡ü' + 
  'm¢J5¥¦§ö©ox®°B±µ' + 
  '»Wv¿6ÀÁÂRÄÈ3Òàwß'; 
 
  V128: array[0..127] of char = Tab1 + Tab2; 
 
function TabelleOK: byte; 
const vbtn = [0..31, 38, 39, 127..159]; 
var i, j: integer; 
begin 
  result := 1; 
  for i := 0 to 127 do 
    if ord(V128[i]) in vbtn {verbotene Zeichen} 
     then exit; 
  result := 2; 
  for i := 0 to 126 do 
    for j := i + 1 to 127 do 
      if V128[i] = V128[j] {doppelte Zeichen} 
       then exit; 
  result := 0; 
end; 
 
function encode(txt: string): string; 
var 
  g: string; 
  i, lg, lt: integer; 
  function zufall: integer; 
  begin 
    result := random(2) * 64; 
  end; 
begin 
  result := ''; 
  if txt = '' then exit; 
  randomize; 
  lt := length(txt); 
  i := lt mod 3; 
  if i = 0 then g := '' else 
    g := stringofchar(#0, 3 - i); 
  lg := length(g); 
  txt := txt + g; 
  inc(lt, lg); 
  i := 1; 
  while i < lt do begin 
    result := result 
      + V128[zufall + ord(txt[i]) shr 2] 
      + V128[zufall + (ord(txt[i]) and 3) shl 4 or ord(txt[i + 1]) shr 4] 
      + V128[zufall + (ord(txt[i + 1]) and 15) shl 2 or ord(txt[i + 2]) shr 6] 
      + V128[zufall + ord(txt[i + 2]) and 63]; 
    inc(i, 3); 
  end; 
  delete(result, 1 + length(result) - lg, lg); 
end; 


function decode(txt: string): string; 
var 
  i, j, lt: integer; 
  a: array of byte; 
begin 
  result := ''; 
  i := 1; 
  while i <= length(txt) do begin 
    if (pos(txt[i], V128) = 0) then 
      delete(txt, i, 1) else inc(i); 
  end; 
  if txt = '' then exit; 
  lt := length(txt); 
  setlength(a, lt + 3); 
  for i := 1 to lt do begin 
    j := (pos(txt[i], V128) - 1); 
    a[i - 1] := j - ord(j > 63) * 64; 
  end; 
  i := 0; 
  while i < lt do begin 
    result := result 
      + chr((a[i] shl 2) or (a[i + 1] shr 4)) 
      + chr((a[i + 1] shl 4) or (a[i + 2] shr 2)) 
      + chr(((a[i + 2] and 3) shl 6) or (a[i + 3] and 63)); 
    inc(i, 4); 
  end; 
  a := nil; 
end; 
 
// ---Beispielaufrufe --- 
 
// verschlüsseln 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  label1.caption := ''; 
  case TabelleOK of 
    1: showmessage('V128 enhält verbotene Zeichen'); 
    2: showmessage('V128 enhält doppelte Zeichen'); 
  else label1.caption := encode(Edit1.text); 
  end; 
end; 
 
// entschlüsseln 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  label2.ShowAccelChar := false; // falls "&" im entschlüsselten Text 
  label2.caption := decode(label1.caption); 
end; 

		

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

		// 3a. Variante von 3 "V128"
		

		// Getestet mit RS 10.4 unter W11

// Der verschlüsselte Text wird wesentlich größer als das Original,
// was aber das Knacken des Codes zusätzlich erschwert. Die Zeichen
// in den Tabellen müssen vom Typ AnsiChar sein.
		

		const 
  Tab1 = '4F2!"#N$%(S+/1,Ñ7Æ8:0;<M=>?@A«CuKgTG9EH)I-L*OØQP' + 
    'UVèX[Ya£bcÙdehij'; 

  Tab2 = 'tÞkÌnpÐqr¬yzÖÇÜs¤äf.×\]{D|Z}l~¡üm¢J5¥¦§ö©ox®°B±Á' + 
    '»Wv¿6ÀµÂRÄÈ3Òàwß'; 
 
  V128: array [0 .. 127] of Ansichar = Tab1 + Tab2; 
 
function TabelleOK: byte; 
const 
  vbtn = [0 .. 31, 38, 39, 127 .. 159]; 
var 
  i, j: integer; 
begin 
  result := 1; 
  for i := 0 to 127 do 
    if ord(V128[i]) in vbtn { verbotene Zeichen } 
    then 
      exit; 
  result := 2; 
  for i := 0 to 126 do 
    for j := i + 1 to 127 do 
      if V128[i] = V128[j] { doppelte Zeichen } 
      then 
        exit; 
  result := 0; 
end; 
 
function encode(s: string): string; 
var 
  g: ansistring; 
  hlp, txt: Rawbytestring; 
  i, lg, lt: integer; 
  c: Ansichar; 
  P: Pansichar; 
  function zufall: integer; 
  begin 
    result := random(2) * 64; 
  end; 
 
begin 
  result := ''; 
  if s = '' then 
    exit; 
  txt := ''; 
  P := @s[1]; 
  for i := 1 to length(s) * 2 do 
  begin 
    txt := txt + P^; 
    inc(P); 
  end; 
  randomize; 
  c := #0; 
  lt := length(txt); 
  i := lt mod 3; 
  if i = 0 then 
    g := '' 
  else 
    g := stringofchar(c, 3 - i); 
  lg := length(g); 
  txt := txt + g; 
  inc(lt, lg); 
  i := 1; 
  while i < lt do 
  begin 
    hlp := hlp + V128[zufall + ord(txt[i]) shr 2] + 
      V128[zufall + (ord(txt[i]) and 3) shl 4 or ord(txt[i + 1]) shr 4] + 
      V128[zufall + (ord(txt[i + 1]) and 15) shl 2 or ord(txt[i + 2]) shr 6] + 
      V128[zufall + ord(txt[i + 2]) and 63]; 
    inc(i, 3); 
  end; 
  delete(hlp, 1 + length(hlp) - lg, lg); 
  result := string(hlp); 
end; 
 
function decode(s: string): string; 
var 
  i, j, lt: integer; 
  a: array of byte; 
  txt: Rawbytestring; 
  P: Pansichar; 
  pc: PChar; 
begin 
  result := ''; 
  if s = '' then 
    exit; 
  txt := ''; 
  P := @s[1]; 
  i := 1; 
  while i < length(s) * 2 do 
  begin 
    if odd(i) then 
      txt := txt + P^; 
    inc(P); 
    inc(i); 
  end; 
  lt := length(txt); 
  setlength(a, lt + 3); 
  for i := 1 to lt do 
  begin 
    j := (pos(txt[i], V128) - 1); 
    a[i - 1] := j - ord(j > 63) * 64; 
  end; 
  txt := ''; 
  i := 0; 
  while i < lt do 
  begin 
    txt := txt + Ansichar((a[i] shl 2) or (a[i + 1] shr 4)) + 
      Ansichar((a[i + 1] shl 4) or (a[i + 2] shr 2)) + 
      Ansichar(((a[i + 2] and 3) shl 6) or (a[i + 3] and 63)); 
    inc(i, 4); 
  end; 
  a := nil; 
  pc := @txt[1]; 
  i := 1; 
  while i < length(txt) do 
  begin 
    result := result + pc^; 
    inc(i, 2); 
    inc(pc); 
  end; 
  result := trimright(result); 
end; 
 
 
// ---Beispielaufrufe --- 
 
// verschlüsseln

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Label1.caption := ''; 
  case TabelleOK of 
    1: 
      showmessage('V128 enhält verbotene Zeichen'); 
    2: 
      showmessage('V128 enhält doppelte Zeichen'); 
  else 
    Label1.caption := encode('UNIݗࢯࢳ۞֏'); 
  end; 
end; 


// entschlüsseln

procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Label2.ShowAccelChar := false; 
  Label2.caption := decode(Label1.caption); 
end;
		

		 
      	

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

// 4. Text zu Zahlen verschlüsseln

// Getestet mit D4 unter Win98 und 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;
      	

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

// 5. Strings verschlüsseln mit Zahlen-Schlüssel

// In dieser Form nur für D4 unter Win98

// Wen es stört, dass bei Methode 1 der verschlüsselte Text 3 x länger wird
// als der Originalstring, der kann die folgende Methode verwenden, welche
// durch Addition (bzw. Subtraktion) von $E0 vermeidet, dass Zeichen unterhalb
// von #32 entstehen. Allerdings sind im Schlüssel nur Ziffern erlaubt,
// wodurch sich die Sicherheit etwas verringert.

          function Ver_Ent_Schl(txt: string; schlsl: longword; verschl: boolean): string; 
var 
  x, p, n: Integer; 
  schluessel: string; 
begin 
  result := ''; 
  p := 0; 
  schluessel := inttostr(schlsl); 
  for x := 1 to length(txt) do begin 
    inc(p); 
    if p > length(schluessel) then p := 1; 
    if verschl then begin 
      n := ord(txt[x]) + ord(schluessel[p]); 
      if n > 255 then n := n - $E0; 
    end else begin 
      n := ord(txt[x]) - ord(schluessel[p]); 
      if n < 32 then n := n + $E0; 
    end; 
    result := result + chr(n); 
  end; 
end; 
 
const passw: longword = 165738904; 
 
// Verschlüsseln (verschl=True) 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  label1.caption := Ver_Ent_Schl(Edit1.text, passw, True); 
end; 
 
// Entschlüsseln (verschl=False) 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Label2.caption := Ver_Ent_Schl(Label1.caption, passw, False); 
end;
      	

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

// 6. Verschlüsselung plus Zufall

// Getestet mit D4 unter Win98 und 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. Verschlüsseln mit zwei Passwörtern

// In dieser Form nur für D4 unter Win98

// Manchmal ist das "Vier-Augen-Prinzip" vorgeschrieben. Das bedeutet, dass
// aus Sicherheitsgünden zwei von einander unabhängige Personen je ein
// geheimes Passwort eingeben müssen, um Text zu ver- oder entschlüsseln.
// Um die Sicherheit zu erhöhen, habe ich zusätzlich den Zufallsgenerator
// eingesetzt. Man hat zwei Verschlüsselungs-Methoden zur Auswahl: FALSE und
// TRUE. Wenn mit TRUE verschlüsselt wurde, muss mit FALSE entschlüsselt werden
// und umgekehrt.

          function 
  Ver_Ent_Schl(txt: string; Methode: boolean; schl_1: Longint; schl_2: DWord): 
    string; 
var 
  x, p, n, lg: Integer; 
  s: string; 
begin 
  p := 0; 
  result := ''; 
  randseed := schl_1; 
  s := inttostr(schl_2); 
  lg := length(s); 
  for x := 1 to length(txt) do begin 
    inc(p); 
    if p > length(s) then p := 1; 
    if Methode then begin 
      n := ord(txt[x]) + ord(s[p]) + random($70 + lg); 
      if n > 255 then n := n - $E0; 
    end else begin 
      n := ord(txt[x]) - ord(s[p]) - random($70 + lg); 
      if n < 32 then n := n + $E0; 
    end; 
    result := result + chr(n); 
  end; 
end; 
 
// Beispielaufruf 
const 
  Key1 = 195678; 
  Key2 = 9854539; 
// Verschlüsseln 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Edit1.text := Ver_Ent_Schl(Edit1.text, FALSE, key1, key2); 
end; 
 
// Entschlüsseln 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Edit1.text := Ver_Ent_Schl(Edit1.text, TRUE, key1, key2); 
end;
      	

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

// 8. Verschlüsseln mit mehreren Passwörtern

// In dieser Form nur für D4 unter Win98

// Hiermit kann man einen String mit einer beliebigen Anzahl Keys verschlüsseln
// (ob's Sinn macht, weiß ich nicht so genau). Verschlüsselungsrelevant ist
// neben den Schlüsselwörtern auch die Ziffernanzahl im jeweiligen Schlüssel.
// Man hat zwei Verschlüsselungs-Methoden zur Auswahl: FALSE und TRUE. Wenn
// mit TRUE verschlüsselt wurde, muss mit FALSE entschlüsselt werden und
// umgekehrt.

          function 
  Ver_Ent_Schl(const txt: string; Methode: boolean; schlssl: array of DWord): 
    string; 
var 
  n, h, i, j: integer; 
  ss: array of string; 
  lg, zl: array of byte; 
begin 
  result := txt; 
  h := high(schlssl); 
  setlength(ss, h + 1); 
  setlength(zl, h + 1); 
  setlength(lg, h + 1); 
  for i := 0 to h do begin 
    ss[i] := inttostr(schlssl[i]); 
    lg[i] := length(ss[i]); 
    zl[i] := 1; 
  end; 
  for i := 1 to length(txt) do begin 
    n := byte(txt[i]); 
    for j := 0 to h do begin 
      if methode then begin 
        n := n + byte(ss[j][zl[j]]) + lg[j]; 
        if n > 255 then n := n - $E0; 
      end else begin 
        n := n - byte(ss[j][zl[j]]) - lg[j]; 
        if n < 32 then n := n + $E0; 
      end; 
      inc(zl[j]); 
      if zl[j] > lg[j] then zl[j] := 1; 
    end; 
    result[i] := char(n); 
  end; 
  zl := nil; 
  lg := nil; 
  ss := nil; 
end; 
 
// Verschlüsseln mit 3 Schlüsseln 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Edit1.text := Ver_Ent_Schl(Edit1.text, TRUE, [10296, 7913, 98765342]); 
end; 
 
// Entschlüsseln mit 3 Schlüsseln 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Edit1.text := Ver_Ent_Schl(Edit1.text, FALSE, [10296, 7913, 98765342]); 
end; 
      	

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

// 9. "3Z"-Verschlüsselung

// In dieser Form nur für D4 unter Win98

// Der Code ist für Leute, die sich keine langen Passwörter merken können.
// Das Passwort besteht nämlich aus 3 Zeichen. Hat die Variable "was" den Wert
// TRUE, dann wird verschlüsselt, bei FALSE wird entschlüsselt. ACHTUNG! Wenn
// ein bereits verschlüsselter Text nochmals verschlüsselt wird, kommt es zu
// Verlusten.

        function VE3Z(txt, schl: string; was: boolean): string; 
var 
  i, z: integer; 
  a: array[0..2] of integer; 
begin 
  if length(schl) > 2 then begin 
    result := ''; 
    z := ord(was) * 2 - 1; 
    for i := 0 to 2 do 
      a[i] := ord(schl[i + 1]) - $F0; 
    for i := 1 to length(txt) do begin 
      if abs(a[0]) >= a[2] then a[1] := -a[1]; 
      result := result + chr((ord(txt[i]) + a[0] * z) mod $100); 
      inc(a[0], a[1]); 
    end; 
  end else result := txt; 
end; 
 
 
// Verschlüsseln 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  memo1.text := VE3Z(memo1.text, 'ö!A', true); 
end; 
 
// Entschlüsseln 
procedure TForm1.Button6Click(Sender: TObject); 
begin 
  memo1.text := VE3Z(memo1.text, 'ö!A', false); 
end;
      	

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

// 9.1. 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;

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

// 10. Text-Verschlüsselung mit Sicherheitspasswort

// In dieser Form nur für D4 unter Win98

// Hiermit können Texte (Textdateien) verschlüsselt werden, wobei
// nach der Verschlüsselung ein sogenanntes Sicherheitspasswort mit
// 10 Stellen zurückgegeben wird. Das Passwort, mit dem verschlüsselt wird,
// kann 3 bis 15 Zeichen haben und ist maßgeblich an der Erzeugung des
// Sicherheitspasswortwes beteiligt, kann aber nicht zur Entschlüsselung
// benutzt werden. Das bedeutet, dass jeder verschlüsselte Text sein eigenes
// 10-stelliges Passwort hat, und nur damit kann der Text auch wieder
// entschlüsselt werden. Außerdem ist per Zufall gesichert, dass der gleiche
// Text immer ein anderes Verschlüsselungsergebnis gibt, auch wenn er mit dem
// gleichen Passwort verschlüsselt wurde. Ebenfalls ist das Sicherheitspasswort
// pro Verschlüsselung neu und einmalig.

        function EnCrypt(const txt, pw: string; out newpw: string): string; 
var 
  x: integer; 
  v: cardinal; 
  P1, P2: PByte; 
  b: byte; 
  function MyRange(const von, bis: Integer): Integer; 
  begin 
    Result := Random(bis - von + 1) + von; 
  end; 
  function Zahl(pw: string): cardinal; 
  var x: integer; 
  begin 
    Result := 0; 
    if length(pw) < 3 then 
      raise exception.create('Das Kennwort muss mindestens 3 Zeichen haben!') 
    else pw := copy(pw, 1, 15); 
    for x := 1 to length(pw) do 
      Result := Result + ord(pw[x]) * (Random(7) + 1); 
  end; 
  function rechnen(const v: cardinal): cardinal; 
  begin 
    Result := (Random(v) + v * v * 13) or Random(v); 
  end; 
begin 
  Randomize; 
  v := rechnen(zahl(pw)); 
  setlength(Result, length(txt) * 2); 
  P1 := @txt[1]; 
  P2 := @Result[1]; 
  for x := 1 to length(txt) do begin 
    b := (v xor P1^) and $FF; 
    if b < 32 then begin 
      P2^ := MyRange(201, 255); 
      inc(P2); 
      P2^ := b + 32; 
    end else begin 
      p2^ := MyRange(32, 126); 
      inc(P2); 
      P2^ := b; 
    end; 
    inc(P2); 
    inc(P1); 
  end; 
  newpw := inttostr(v); 
  for x := 1 to length(newpw) do 
    if odd(x) then 
      newpw[x] := chr(ord(newpw[x]) + 49 + Random(2) * 10); 
  while length(newpw) < 10 do insert(chr(Random(3) + 120), 
      newpw, random(length(newpw) + 1) + 1); 
end; 
 
function DeCrypt(const txt: string; pw: string): string; 
var 
  x: Integer; 
  v: cardinal; 
  P1, P2: PByte; 
begin 
  try 
    x := 1; 
    pw := lowercase(pw); 
    while x <= length(pw) do 
      if ord(pw[x]) > 119 then delete(pw, x, 1) 
      else inc(x); 
    for x := 1 to length(pw) do 
      if odd(x) then begin 
        pw[x] := chr(ord(pw[x]) - 49 - ord(ord(pw[x]) > 106) * 10); 
      end; 
    v := strtoint(pw); 
    setlength(Result, length(txt) div 2); 
    P1 := @txt[1]; 
    P2 := @Result[1]; 
    x := 1; 
    while x < length(txt) do begin 
      if P1^ > 200 then begin 
        inc(P1); 
        P2^ := (v xor (P1^ - 32)) and $FF; 
      end else begin 
        inc(P1); 
        P2^ := (v xor P1^) and $FF; 
      end; 
      inc(P1); 
      inc(P2); 
      inc(x, 2); 
    end; 
  except 
    raise exception.create('Entschlüsselung nicht möglich!'); 
  end; 
end; 
 
// Beispielaufruf 
 
var 
  pwx: string; // Sicherheitspasswort
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  Memo1.lines.loadfromfile('c:\Test.txt'); 
  Memo2.text := EnCrypt(Memo1.text, 'Mein Passwort', pwx); 
  Label1.caption := pwx; 
  Memo2.lines.savetofile('c:\verschl.txt'); 
end; 
 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  Memo1.lines.loadfromfile('c:\verschl.txt'); 
  Memo2.text := DeCrypt(Memo1.text, pwx); 
end;
      	

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

// 11. Text-Verschlüsselung mit Vorbehandlung

// Getestet mit D4 unter Win98 und 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;
		

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

// 12. Ganz simple Text-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;