Tips (1541)

Tip Rating (14):

unit CoderDeCoder;
{$X+}

interface

type
  TVerSchluesselArt = (sUniCode, sHexCode, sNormalStr);
  Str002 = string[2];
const
  CRandSeed: Int64 = 258974566;//Beispiel
  SKey: Int64      = 458795222;
  MKey: Int64      = 123456899;
  AKey: Int64      = 12345685525;

function VerEntschluesseln(Value: string; Flag: Boolean;
  Schl: TVerSchluesselArt): string;
function DateiVerEndSchluesseln(QuellDateiname, ZielDateiname: string): Boolean;

  {Folgen Function globalisiert muß aber nicht***********************************}

function CharToHexStr(Value: Char): string;
function CharToUniCode(Value: Char): string;
function Hex2Dec(Value: Str002): Byte;
function HexStrCodeToStr(Value: string): string;
function UniCodeToStr(Value: string): string;

implementation

uses
  Sysutils;

const
  ChS = '0123456789abcdefghijklmnopqrstuvwxyz';
  // Da ich nicht genau weiß welche Zeichen bei, z.B. der Übertragung zum I-Net codiert werden
  // habe ich nur die genommen, von denen ich vermute das sie nicht codiert werden.
  // Wer möchte kann "Chs" vervollständigen. Alle Zeichen in Chs werden "nicht" hex-codiert.
  // bei A..Z wird automatisch die Groß- und Kleinschrift "nicht" hex-codiert
  // Die Funktion:
  // function StrToUniCode(Value:string):string; und
  // function UniCodeToStr(Value:string):string;
  // machen es daher möglich Strings ins I-Net zu übertragen
  // Die Umwandlung in String-Hex-Zahlen muß stattfinden weil sonst wenn z.B. #0 auftaucht der
  // String dort abgeschnitten werden würde. *g

var
  SchluesselSatz: string;

function CharToHexStr(Value: Char): string;
var
  Ch: Char;
begin
  Result := IntToHex(Ord(Value), 2);
  if Ch = #0 then Result := IntToHex(Ord(Value), 2);
end;

//------------------------------------------------------------------------------
function CharToUniCode(Value: Char): string;
var
  S1: string;
  Ch: Char;
begin
  Result := '';
  S1     := AnsiUpperCase(ChS);
  Ch     := UpCase(Value);
  if StrScan(PChar(S1), Ch) = nil then Result := '%' + IntToHex(Ord(Value), 2)
  else 
    Result := Value;
  if Ch = #0 then Result := '%' + IntToHex(Ord(Value), 2)
end;

//------------------------------------------------------------------------------
function Hex2Dec(Value: Str002): Byte;
var
  Hi, Lo: Byte;
begin
  Hi := Ord(Upcase(Value[1]));
  Lo := Ord(Upcase(Value[2]));
  if Hi > 57 then Hi := Hi - 55 
  else 
    Hi := Hi - 48;
  if Lo > 57 then Lo := Lo - 55 
  else 
    Lo := Lo - 48;
  Result := 16 * Hi + Lo
end;

//------------------------------------------------------------------------------
function HexStrCodeToStr(Value: string): string;
var
  i: Integer;
begin
  I      := 1;
  Result := '';
  repeat
    Result := Result + chr(Hex2Dec(Copy(Value, I, 2)));
    Inc(I, 2);
  until I > Length(Value);
end;

//------------------------------------------------------------------------------
function UniCodeToStr(Value: string): string;
var
  I: Integer;
  function HexToStr: string;
  begin
    Result := chr(Hex2Dec(Copy(Value, I + 1,2)));
    Inc(I, 2);
  end;
begin
  I      := 1;
  Result := '';
  try
    repeat
      if Value[I] = '%' then Result := Result + HexToStr
      else 
        Result := Result + Value[I];
      Inc(I);
    until I > Length(Value);
  except
    Result := '';
  end;
end;

//------------------------------------------------------------------------------
function Verschluessel(Value: string; Schl: TVerSchluesselArt): string;
var
  I, J: Integer;
  SKey1: Int64;
begin
  Result := '';
  SKey1  := SKey;
  J      := 1;
  for I := 1 to Length(Value) do
  begin
    case Schl of
      sUniCode: Result   := Result + CharToUniCode(Char(Byte(Value[I]) xor
          Byte(SchluesselSatz[J]) xor (SKey1 shr 16)));
      sHexCode: Result   := Result + CharToHexStr(Char(Byte(Value[I]) xor
          Byte(SchluesselSatz[J]) xor (SKey1 shr 16)));
      sNormalStr: Result := Result + Char(Byte(Value[I]) xor Byte(SchluesselSatz[J])
          xor (SKey1 shr 16));
    end;

    SKey1 := (Byte(SchluesselSatz[J]) + SKey1) * MKey + AKey;
    Inc(J);
    if J > Length(SchluesselSatz) then J := 1;
  end;
end;

//------------------------------------------------------------------------------
function Entschluessel(Value: string): string;
var
  I, J: Integer;
  SKey1: Int64;
begin
  Result := '';
  SKey1  := SKey;
  J      := 1;
  for I := 1 to Length(Value) do
  begin
    Result := Result + Chr(Ord(Value[I]) xor (Byte(SchluesselSatz[J]) xor (SKey1 shr 16)));
    SKey1  := (Byte(SchluesselSatz[J]) + SKey1) * MKey + AKey;
    Inc(J);
    if J > Length(SchluesselSatz) then J := 1;
  end;
end;

//------------------------------------------------------------------------------
function VerEntschluesseln(Value: string; Flag: Boolean;
  Schl: TVerSchluesselArt): string;
begin
  if Flag then Result := Verschluessel(Value, Schl)
  else 
  begin
    case Schl of
      sUniCode: Result   := Entschluessel(UniCodeToStr(Value));
      sHexCode: Result   := Entschluessel(HexStrCodeToStr(Value));
      sNormalStr: Result := Entschluessel(Value);
    end;
  end;
end;

//------------------------------------------------------------------------------
function DateiVerEndSchluesseln(QuellDateiname, ZielDateiname: string): Boolean;
var
  Gelesen: Integer;
  Quelle, Ziel: file;
  Buf: array [0..65535] of Byte;

  procedure Coder(I: Integer);
  var
    J: Integer;
    SKey1: Int64;
  begin
    SKey1 := SKey;
    J     := 1;
    for I := 0 to I do
    begin
      Buf[I] := Buf[I] xor Byte(SchluesselSatz[J]) xor (SKey1 shr 16);
      SKey1  := (Byte(SchluesselSatz[J]) + SKey1) * MKey + AKey;
      Inc(J);
      if J > Length(SchluesselSatz) then J := 1;
    end;
  end;
begin
  AssignFile(Quelle, QuellDateiname);
  {$I-}reset(Quelle, 1);{$I+}
  Result := not Boolean(ioResult);
  if not Result then  Exit;

  AssignFile(Ziel, ZielDateiname);
  {$I-}reWrite(Ziel, 1);{$I+}
  Result := not Boolean(ioResult);
  if not Result then  Exit;

  blockRead(Quelle, Buf, SizeOf(Buf), Gelesen);
  while Gelesen <> 0 do
  begin
    Coder(Gelesen);
    blockWrite(Ziel, Buf, Gelesen);
    blockRead(Quelle, Buf, SizeOf(Buf), Gelesen);
  end;
  CloseFile(Quelle);
  CloseFile(Ziel);
end;

{initialization****************************************************************}
var
  I, J: Integer;
  C1, C2: Char;

initialization
  begin
    SchluesselSatz := '';
    RandSeed       := CRandSeed;
    for I := 0 to 255 do
      for J := 1 to 255 do SchluesselSatz := SchluesselSatz + chr(J);
    for I := 1 to Length(SchluesselSatz) do
    begin
      J  := Random(Length(SchluesselSatz)) + 1;
      C1 := SchluesselSatz[J];
      C2 := SchluesselSatz[I];
      SchluesselSatz[I] := C1;
      SchluesselSatz[J] := C2;
    end;
    Randomize;
  end;
end.Beispiele:
//------------------------------------------------------------------------------
procedure TMain.Button1Click(Sender: TObject);
var
  VerSch, EntSch: string;
begin
  VerSch := 'Ich bin ein Test';

  //Möglichkeit 1 (Wegen der Null-Byte muß eine Umwandlung Stattfinden) Ini Daten wäre eine Anwendung}
  //    VerSch  := VerEntschluesseln(VerSch,true,sHexCode);
  //    EntSch  := VerEntschluesseln(VerSch,false,sHexCode);

  //Möglichkeit 2 z.B. für metohde Post bei Html-Sachen}
  VerSch := VerEntschluesseln(VerSch, True, sUniCode);
  EntSch := VerEntschluesseln(VerSch, False, sUniCode);

  // Möglichkeit 3 (Macht aber nicht wirklich Sinn wegen dem Auftreten von ggf. Null-Byte
  // ein Memofeld/TString würde den Text nach #0 abschneiden
  //    VerSch := VerEntschluesseln(VerSch,true,sNormalStr);
  //    EntSch := VerEntschluesseln(VerSch,false,sNormalStr);

  Memo1.Text := EntSch;
  Memo2.Text := VerSch;
end;

//------------------------------------------------------------------------------
procedure TMain.Button2Click(Sender: TObject);
begin
  {Die Dateilänge wird nicht länger

  Tipp: Vorher, NICHT nachher die Datei Zippen dann wird sie noch unleserlicher und kleiner *g
  5 MB dauern selbst mit einem Schwachen Rechner unter 1 sek}
  DateiVerEndSchluesseln('Quelle.mpg', 'Ziel1.txt'); // Verschlüssen
  DateiVerEndSchluesseln('Ziel1.txt', 'Ziel2.txt');  // und wieder Endschlüssen
end;