// Mit dem folgenden Code wird (deutscher)Text anhand einer (individuell
// erstellten) Tabelle verschlüsselt. Diese setzt sich zusammen aus einer
// Standardtabelle, sowie aus der Variablen "zusatz", in der ich auch einige
// gängige Zeichen aus Word-Texten verwende, um Texte, die über "Einfügen"
// eingefügt wurden, verschlüsseln zu können.
// Die Verschlüsselung kann nach Wunsch über mehrere Stationen (sogenannte
// "Räder") erfolgen. Jedes "Rad" wird über sein eigenes, dreistelliges
// Passwort gesteuert. Sobald ein Zeichen durch ein Rad verschlüsselt wurde,
// wird das entsprechende Rad einen Schritt weitergeschaltet. Das Prinzip
// habe ich ein klein wenig der berühmten "Enigma" entlehnt. Die Passwörter
// müssen in einem Ziffernstring zusammengefasst werden. Die erste Stelle
// bestimmt, wieviel Räder verwendet werden sollen (1 bis 9), wobei eine
// '0' in eine '1' umgewandelt wird. Es sind keine gleichen Einzel-Passwörter
// erlaubt.
// Die Verschlüsselung besitzt 4 Kriterien. Erstens weiß ein Außenstehender
// schon mal nicht, welche Tabelle verwendet wurde. Zweitens ist unbekannt,
// wieviel Räder verwendet wurden. Drittens sind die Passwörter der einzelnen
// Räder unbekannt, und viertens wird durch das Weiterschalten der Räder das
// gleiche Zeichen jedesmal anders übersetzt.
// Um Fehler zu vermeiden, werden spezielle Routinen zum Speichern und
// Laden verwendet.
// Hinweis: Nach einer Veränderung der Tabelle sollte sicherheitshalber
// ein umfassender Test erfolgen.

// Zwei Beispiele für das Gesamtpasswort:

// Das Passwort muss beim Programmstart angegeben werden.
// Für ein besseres Verständnis des Ganzen, können Sie ein
// DEMO-Programm herunterladen.

// Falls Sie Interesse an einem erweiterten Programm haben, welches
// auch Buchstaben als Passwort zulässt und die Räderanzahl über
// einen Regler einstellt, dann laden Sie SigmaX.zip herunter.

// Getestet mit RS 10.4 unter Win11

type 
  TForm1 = class(TForm) 
    Edit1: TEdit; 
    Memo1: TMemo; 
    Gauge1: TGauge; 
    Label1: TLabel; 
    Label2: TLabel; 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    Button4: TButton; 
    Button5: TButton; 
    OpenTextFileDialog1: TOpenTextFileDialog; 
    SaveTextFileDialog1: TSaveTextFileDialog; 
    Label3: TLabel; 
    procedure FormCreate(Sender: TObject); 
    procedure Edit1Change(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
    procedure Button4Click(Sender: TObject); 
    procedure Memo1Change(Sender: TObject); 
    procedure Button5Click(Sender: TObject); 
    procedure Edit1KeyPress(Sender: TObject; var Key: Char); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
    function Test(S: String; out St: Integer): Integer; 
    function Teilen(S: String): Boolean; 
    procedure MakeWheel(sd, tr: Integer; var Wheel: String); 
    function InOut(var Wheel: string; C: Char): Char; 
    function OutIn(var Wheel: string; C: Char): Char; 
    function Verschl(Mem: TCustomMemo): String; 
    procedure grund(tr: Integer = 0); 
    function Entschl(Mem: TCustomMemo): string; 
    function PW: Boolean; 
    function Prf(Mem: TCustomMemo): Boolean; 
    procedure enabl(B: Boolean; Bttn: TButton = nil); 
    procedure Mix(var TS: String); 
    function pruefz(a: String; B: Boolean = True): String; 
    procedure L3(v: Boolean); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.dfm} 
 
uses System.WideStrUtils, System.UITypes; 
 
const 
  prfzl = 5; 
 
var 
  Zahl, Lg: Integer; 
  Rd: Array of Integer; 
  Rad: Array of String; 
  Sperre: Boolean = True; 
  Tabelle, Zusatz, pws: String; 
 
procedure TForm1.FormCreate(Sender: TObject); 
  function Correct: Boolean; 
  var 
    X, Y: Integer; 
  begin 
    Result := True; 
    for X := 0 to pred(Lg) do 
      for Y := succ(X) to Lg do 
        if Tabelle[X] = Tabelle[Y] then 
        begin 
          Result := False; 
          Break; 
        end; 
  end; 
 
begin 
  Tabelle := 
    'ABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜabcdefghijklmnopqrstuvwxyzäöü1234567890' + 
    '.,;:!°"§%&/()=?+-*#{}[]~<>\_@ßµ$€£¥«»'#32#13#10#39#9#160; 
 
  Zusatz := 'æœÛÈÉÀÁ·¼½¾®©ÓÒòóô±²³ªF„“…’‘×èéàáîíâìaïñûç' + Chr(8218) + Chr(8211) 
    + Chr(8195) + Chr(8226) + Chr(8237) + Chr(8236) + Chr(8722) + Chr(8221); 
 
  Tabelle := Tabelle + Zusatz; 
  Lg := Length(Tabelle); 
 
  if not Correct then 
  begin 
    ShowMessage('Fehlerhafte Tabelle'); 
    halt; 
  end; 
 
  // --- Das Folgende kann auch im Objektinspektor eingestellt werden --- 
  Caption := 'Sigma'; 
  Edit1.Text := ''; 
  Button1.Caption := 'Verschlüsseln'; 
  Button2.Caption := 'Entschlüsseln'; 
  Button3.Caption := 'Weiter'; 
  Button4.Caption := 'Laden'; 
  Button5.Caption := 'Speichern'; 
  Label1.Caption := 'Text schreiben, einfügen oder laden'; 
  Label2.Caption := 'Geben Sie ein Passwort ein'; 
  Label1.Visible := False; 
  Label3.Visible := False; 
  Memo1.Visible := False; 
  Memo1.HideSelection := False; 
  Button1.Enabled := False; 
  Button2.Enabled := False; 
  Button1.Visible := False; 
  Button2.Visible := False; 
  Button4.Visible := False; 
  Button5.Visible := False; 
  Button5.Enabled := False; 
  Button3.Enabled := False; 
  Button3.Visible := True; 
  Memo1.Text := ''; 
  Memo1.BorderStyle := bsNone; 
  Memo1.WordWrap := True; 
  Memo1.ScrollBars := ssVertical; 
  Gauge1.MinValue := 0; 
  Gauge1.Visible := False; 
  // --------------------------------------------------------- 
  Label1.Left := (Clientwidth - Label1.width) div 2; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  Rd := nil; 
  Rad := nil; 
end; 
 
function TForm1.pruefz(a: String; B: Boolean = True): String; 
var 
  X, Z, I, Erg: Integer; 
begin 
  I := 112 - Ord(B) * 18; 
  Erg := 1; 
  Result := ''; 
  for Z := 2 to succ(prfzl) do 
  begin 
    for X := 1 to Length(a) do 
      Erg := (Erg * 2 + Ord(a[X]) * (Z - Ord(odd(X)) * (Z - 1))) mod 97; 
    Result := Result + Char(I + Erg mod 10); 
  end; 
end; 
 
procedure TForm1.Mix(var TS: String); 
var 
  I, X, Y, L: Cardinal; 
  S: Char; 
begin 
  L := Length(TS); 
  for I := 0 to pred(L) do 
  begin 
    X := succ(Random(L)); 
    repeat 
      Y := succ(Random(L)); 
    until Y <> X; 
    S := TS[Y]; 
    TS[Y] := TS[X]; 
    TS[X] := S; 
  end; 
end; 
 
function TForm1.InOut(var Wheel: String; C: Char): Char; 
var 
  P: Integer; 
begin 
  P := pos(C, Tabelle); 
  Result := Wheel[P]; 
  Wheel := Wheel[Lg] + copy(Wheel, 1, pred(Lg)); 
end; 
 
function TForm1.OutIn(var Wheel: String; C: Char): Char; 
var 
  P: Integer; 
begin 
  P := pos(C, Wheel) - 1; 
  if P = 0 then 
    P := Lg; 
  Result := Char(Tabelle[P]); 
  Wheel := copy(Wheel, 2, pred(Lg)) + Wheel[1]; 
end; 
 
function TForm1.Test(S: string; Out St: Integer): Integer; // Probe auf Tabelle 
var 
  I, P: Integer; 
begin 
  Result := 0; 
  for I := 1 to Length(S) do 
  begin 
    P := pos(S[I], Tabelle); 
    if P < 1 then 
    begin 
      St := I; 
      Result := Ord(S[I]); 
      Break; 
    end; 
  end; 
end; 
 
procedure TForm1.Edit1Change(Sender: TObject); 
begin 
  Button3.Enabled := Trim(Edit1.Text) <> ''; 
end; 
 
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); 
begin 
  if Key = #13 then 
    Button3Click(Sender); 
end; 
 
function TForm1.Teilen(S: string): Boolean; 
var 
  X, Y, C: Integer; 
  B: Boolean; 
begin 
  Result := False; 
  if Length(S) mod 3 <> 1 then 
    exit; 
  Zahl := StrtoIntdef(copy(S, 1, 1), 0); 
  if Zahl < 1 then 
    Zahl := 1; 
  setlength(Rd, Zahl); 
  setlength(Rad, Zahl); 
  C := 2; 
  for X := 0 to pred(Zahl) do 
  begin 
    Rd[X] := StrtoIntdef(copy(S, C, 3), 0); 
    if Rd[X] = 0 then // Passwort 000 oder Buchstaben verboten 
      exit; 
    inc(C, 3); 
  end; 
  B := True; 
  for X := 0 to Zahl - 2 do // keine gleichen Passwörter erlaubt 
    for Y := succ(X) to pred(Zahl) do 
    begin 
      if Rd[X] = Rd[Y] then 
      begin 
        B := False; 
        Break; 
      end; 
    end; 
  Result := B; 
end; 
 
procedure TForm1.MakeWheel(sd, tr: Integer; var Wheel: String); 
var 
  R: Integer; 
begin 
  Wheel := Tabelle; 
  Randseed := sd; 
  Mix(Wheel); 
  R := succ(Random(Lg)) - tr; 
  while R < 1 do 
    inc(R, Lg); 
  while R > Lg do 
    dec(R, Lg); 
  Wheel := copy(Wheel, R, maxint) + copy(Wheel, 1, R - 1); 
end; 
 
procedure TForm1.Memo1Change(Sender: TObject); 
begin 
  if not Sperre then 
  begin 
    Button1.Enabled := Memo1.Text <> ''; 
    Button2.Enabled := Button1.Enabled; 
    Button5.Enabled := Button1.Enabled; 
    Button3.Enabled := Button1.Enabled; 
    Label1.Visible := not Button1.Enabled; 
    L3(Button1.Enabled); 
  end; 
end; 
 
function TForm1.Prf(Mem: TCustomMemo): Boolean; 
var 
  T, P, I: Integer; 
  procedure B1; 
  begin 
    if Memo1.Text <> '' then 
    begin 
      Button1.Enabled := True; 
      Button1.SetFocus; 
    end; 
  end; 
 
begin 
  Result := True; 
  T := Test(Mem.Text, P); 
  if T <> 0 then 
  begin 
    Mem.Selstart := pred(P); 
    Mem.SelLength := 1; 
    Result := False; 
    I := MessageDlg('Ein Zeichen mit der Ordnungszahl ' + IntToStr(T) + 
      ' ist nicht erlaubt.'#13#10 + 'Entfernen?', mtError, 
      [mbYes, mbNo, mbAll], 0); 
    case I of 
      mryes: 
        begin 
          Memo1.ClearSelection; 
          B1; 
        end; 
      mrAll: 
        begin 
          Mem.Text := StringReplace(Memo1.Text, Chr(T), '', [rfReplaceAll]); 
          B1; 
        end; 
    else 
      Mem.SetFocus; 
    end; 
  end; 
end; 
 
function TForm1.Verschl(Mem: TCustomMemo): string; 
var 
  I, X, L: Integer; 
  C: Char; 
  S: String; 
begin 
  Result := ''; 
  S := Mem.Text; // Geschwindigkeitsvorteil 
  L := Length(S); 
  if L > 2000000000 then 
  begin 
    ShowMessage('Der Text ist zu lang. Bitte das Schriftstück splitten!'); 
    exit; 
  end; 
  grund; 
  Gauge1.MaxValue := L; 
  for X := 1 to L do 
  begin 
    C := InOut(Rad[0], S[X]); 
    for I := 1 to pred(Zahl) do 
      C := InOut(Rad[I], C); 
    Result := Result + C; 
    Gauge1.Progress := Gauge1.Progress + 1; 
  end; 
end; 
 
function TForm1.PW: Boolean; 
var 
  B: Boolean; 
begin 
  B := Teilen(Edit1.Text); 
  if not B then 
  begin 
    Result := False; 
    ShowMessage('Passwort ungültig'); 
  end 
  else 
  begin 
    Edit1.Visible := False; 
    Result := True; 
  end; 
end; 
 
procedure TForm1.grund(tr: Integer = 0); 
var 
  I: Integer; 
begin 
  for I := 0 to pred(Zahl) do 
    MakeWheel(Rd[I], tr, Rad[I]); 
end; 
 
function TForm1.Entschl(Mem: TCustomMemo): string; 
var 
  X, I, L: Integer; 
  C: Char; 
  S, prfz, vergl, pwv: String; 
 
  function prfzp: String; 
  begin 
    Result := copy(S, succ(L - prfzl), prfzl); 
    dec(L, prfzl); 
    S := copy(S, 1, L); 
  end; 
 
begin 
  S := Mem.Text; 
  L := Length(S); 
  pwv := prfzp; 
  vergl := prfzp; 
  prfz := pruefz(S); 
  if (vergl <> prfz) or (pwv <> pws) then 
  begin 
    if MessageDlg 
      ('Der Text wurde entweder manipuliert, mit einem Fremdprogramm ' + 
      'verschlüsselt, oder es wurde ein anderes Passwort benutzt. ' + 
      'Deshalb wird das Ergebnis sehr wahrscheinlich unleserlich sein.' + 
      #13#10#10'Trotzdem weiter?', mtWarning, [mbYes, mbNo], 0) <> mryes then 
    begin 
      Result := ''; 
      exit; 
    end; 
  end; 
  grund(L); 
  Result := S; 
  Gauge1.MaxValue := L; 
  for X := L downto 1 do 
  begin 
    C := OutIn(Rad[pred(Zahl)], S[X]); 
    for I := Zahl - 2 downto 0 do 
      C := OutIn(Rad[I], C); 
    Gauge1.Progress := Gauge1.Progress + 1; 
    Result[X] := C; 
  end; 
end; 
 
procedure TForm1.L3(v: Boolean); 
begin 
  Label3.Visible := v; 
  Label3.Caption := FormatFloat('#,##0 Zeichen', Memo1.GetTextLen); 
  Label3.Left := (Clientwidth - Label3.width) div 2; 
end; 
 
procedure TForm1.enabl(B: Boolean; Bttn: TButton = nil); 
begin 
  Button1.Enabled := B; 
  Button2.Enabled := B; 
  Button3.Enabled := B; 
  Button4.Enabled := B; 
  Button5.Enabled := B; 
  if Bttn <> nil then 
    Bttn.Enabled := not B; 
end; 
 
// Verschlüsseln 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  S, prfz: String; 
begin 
  Screen.Cursor := crHourGlass; 
  if not Prf(Memo1) then 
  begin 
    Screen.Cursor := crDefault; 
    exit; 
  end; 
  Sperre := True; 
  enabl(False); 
  S := Verschl(Memo1); 
  if S <> '' then 
  begin 
    prfz := pruefz(S); 
    S := S + prfz + pws; 
    Memo1.Text := S; 
  end; 
  Gauge1.Progress := 0; 
  enabl(True, Button1); 
  Screen.Cursor := crDefault; 
  Sperre := False; 
end; 
 
// Entschlüsseln 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  S: String; 
begin 
  Screen.Cursor := crHourGlass; 
  Sperre := True; 
  enabl(False); 
  Button2.Enabled := False; 
  S := Entschl(Memo1); 
  enabl(True, Button2); 
  if S <> '' then 
    Memo1.Text := S 
  else 
    Button2.Enabled := True; 
  Screen.Cursor := crDefault; 
  Gauge1.Progress := 0; 
  Button1.Enabled := True; 
  Sperre := False; 
end; 
 
// Starten 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  if Memo1.Visible then 
  begin 
    Memo1.Text := ''; 
    enabl(False, Button4); 
    Memo1.SetFocus; 
    exit; 
  end; 
  if not PW then 
    exit; 
  pws := Edit1.Text; 
  Edit1.Text := ''; 
  pws := pruefz(pws, False); 
  Edit1.Visible := False; 
  Memo1.Visible := True; 
  Button1.Visible := True; 
  Button2.Visible := True; 
  Button4.Visible := True; 
  Button5.Visible := True; 
  Button3.Enabled := False; 
  Button3.Caption := 'Löschen'; 
  Gauge1.Visible := True; 
  Label1.Visible := True; 
  Memo1.SetFocus; 
  Sperre := False; 
end; 
 
// Laden 
procedure TForm1.Button4Click(Sender: TObject); 
var 
  I: Integer; 
  a: Ansistring; 
  C: Ansichar; 
  S: String; 
  FS: TFilestream; 
begin 
  if OpenTextFileDialog1.execute then 
  begin 
    Screen.Cursor := crHourGlass; 
    Memo1.Clear; 
    enabl(False); 
    Application.ProcessMessages; 
    a := ''; 
    FS := TFilestream.Create(OpenTextFileDialog1.Filename, fmOpenRead); 
    Gauge1.MaxValue := FS.Size; 
    For I := 1 to Gauge1.MaxValue do 
    begin 
      FS.ReadBuffer(C, 1); 
      a := a + C; 
      Gauge1.Progress := I; 
      Application.ProcessMessages; 
    end; 
    if System.WideStrUtils.IsUTF8String(a) then 
    begin 
      if System.WideStrUtils.HasUTF8BOM(a) then 
        a := copy(a, 4, maxint); 
      S := System.UTF8ToString(a); 
    end 
    else 
      S := String(a); 
    Memo1.Text := S; 
    enabl(True); 
    FS.Free; 
    Gauge1.Progress := 0; 
    Screen.Cursor := crDefault; 
  end; 
end; 
 
// Speichern 
procedure TForm1.Button5Click(Sender: TObject); 
var 
  FS: TFilestream; 
  I: Integer; 
  a: Ansistring; 
begin 
  if SaveTextFileDialog1.execute then 
  begin 
    Screen.Cursor := crHourGlass; 
    enabl(False); 
    a := System.AnsiToUtf8(Memo1.Text); 
    FS := TFilestream.Create(SaveTextFileDialog1.Filename, fmCreate); 
    Gauge1.MaxValue := Length(a); 
    for I := 1 to Gauge1.MaxValue do 
    begin 
      FS.WriteBuffer(a[I], 1); 
      Gauge1.Progress := I; 
      Application.ProcessMessages; 
    end; 
    FS.Free; 
    enabl(True); 
    Gauge1.Progress := 0; 
    Screen.Cursor := crDefault; 
  end; 
end; 

Zugriffe seit 6.9.2001 auf Delphi-Ecke