DES算法Delphi源代码

unit Unit1;

interface

uses
  Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
  Dialogs,StdCtrls;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Button1: TButton;
    Button2: TButton;
    Label3: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  TKeyByte = array[0..5] of Byte;
  TDesMode = (dmEncry,dmDecry);

  function EncryStr(Str,Key: String): String;
  function DecryStr(Str,Key: String): String;
  function EncryStrHex(Str,Key: String): String;
  function DecryStrHex(StrHex,Key: String): String;
  
const
  BitIP: array[0..63] of Byte =   //初始值置IP
    (57,49,41,33,25,17,  9,  1,
     59,51,43,35,27,19,11,  3,
     61,53,45,37,29,21,13,  5,
     63,55,47,39,31,23,15,  7,
     56,48,40,32,24,16,  8,  0,
     58,50,42,34,26,18,10,  2,
     60,52,44,36,28,20,12,  4,
     62,54,46,38,30,22,14,  6 );

  BitCP: array[0..63] of Byte = //逆初始置IP-1
    ( 39,63,
      38,  6,62,
      37,61,
      36,60,
      35,59,
      34,58,
      33,57,
      32,56,24 );

  BitExp: array[0..47] of Integer = // 位选择函数E
    ( 31,1,2,3,4,5,6,7,8,9,
      11,
      21,0  );

  BitPM: array[0..31] of Byte =  //置换函数P
    ( 15,
       1,119); font-size:13px; line-height:24px">   sBox: array[0..7] of array[0..63] of Byte =    //S盒
    ( ( 14,
         0,
         4,
        15,13 ),

      ( 15,
         3,
        13,  9 ),119); font-size:13px; line-height:24px">       ( 10,
         1,12 ),119); font-size:13px; line-height:24px">       (  7,
        10,14 ),119); font-size:13px; line-height:24px">       (  2,
        14,
        11,  3 ),119); font-size:13px; line-height:24px">       ( 12,
         9,119); font-size:13px; line-height:24px">       (  4,
         6,119); font-size:13px; line-height:24px">       ( 13,
         7,
         2,11 ) );

  BitPMC1: array[0..55] of Byte = //选择置换PC-1
    ( 56,
       0,
       9,
      18,
      62,
       6,
      13,
      20,  3 );

  BitPMC2: array[0..47] of Byte =//选择置换PC-2 
    ( 13,
       2,
      22,
      15,
      40,
      29,
      43,
      45,31 );

var
  Form1: TForm1;
  subKey: array[0..15] of TKeyByte; 

implementation

{$R *.dfm}

procedure initPermutation(var inData: array of Byte);
var
  newData: array[0..7] of Byte;
  i: Integer;
begin
  FillChar(newData,0);
  for i := 0 to 63 do
    if (inData[BitIP[i] shr 3] and (1 shl (7- (BitIP[i] and $07)))) <> 0 then
      newData[i shr 3] := newData[i shr 3] or (1 shl (7-(i and $07)));
  for i := 0 to 7 do inData[i] := newData[i];
end;

procedure conversePermutation(var inData: array of Byte);
var
  newData: array[0..7] of Byte;
  i: Integer;
begin
  FillChar(newData,0);
  for i := 0 to 63 do
    if (inData[BitCP[i] shr 3] and (1 shl (7-(BitCP[i] and $07)))) <> 0 then
      newData[i shr 3] := newData[i shr 3] or (1 shl (7-(i and $07)));
  for i := 0 to 7 do inData[i] := newData[i];
end;

procedure expand(inData: array of Byte; var outData: array of Byte);
var
  i: Integer;
begin
  FillChar(outData,0);
  for i := 0 to 47 do
    if (inData[BitExp[i] shr 3] and (1 shl (7-(BitExp[i] and $07)))) <> 0 then
      outData[i shr 3] := outData[i shr 3] or (1 shl (7-(i and $07)));
end;

procedure permutation(var inData: array of Byte);
var
  newData: array[0..3] of Byte;
  i: Integer;
begin
  FillChar(newData,0);
  for i := 0 to 31 do
    if (inData[BitPM[i] shr 3] and (1 shl (7-(BitPM[i] and $07)))) <> 0 then
      newData[i shr 3] := newData[i shr 3] or (1 shl (7-(i and $07)));
  for i := 0 to 3 do inData[i] := newData[i];
end;

function si(s,inByte: Byte): Byte;
var
  c: Byte;
begin
  c := (inByte and $20) or ((inByte and $1e) shr 1) or
    ((inByte and $01) shl 4);
  Result := (sBox[s][c] and $0f);
end;

procedure permutationChoose1(inData: array of Byte;
  var outData: array of Byte);
var
  i: Integer;
begin
  FillChar(outData,0);
  for i := 0 to 55 do
    if (inData[BitPMC1[i] shr 3] and (1 shl (7-(BitPMC1[i] and $07)))) <> 0 then
      outData[i shr 3] := outData[i shr 3] or (1 shl (7-(i and $07)));
end;

procedure permutationChoose2(inData: array of Byte;
  var outData: array of Byte);
var
  i: Integer;
begin
  FillChar(outData,0);
  for i := 0 to 47 do
    if (inData[BitPMC2[i] shr 3] and (1 shl (7-(BitPMC2[i] and $07)))) <> 0 then
      outData[i shr 3] := outData[i shr 3] or (1 shl (7-(i and $07)));
end;

procedure cycleMove(var inData: array of Byte; bitMove: Byte);
var
  i: Integer;
begin
  for i := 0 to bitMove - 1 do
  begin
    inData[0] := (inData[0] shl 1) or (inData[1] shr 7);
    inData[1] := (inData[1] shl 1) or (inData[2] shr 7);
    inData[2] := (inData[2] shl 1) or (inData[3] shr 7);
    inData[3] := (inData[3] shl 1) or ((inData[0] and $10) shr 4);
    inData[0] := (inData[0] and $0f);
  end;
end;

procedure makeKey(inKey: array of Byte; var outKey: array of TKeyByte);
const
  bitdisplace: array[0..15] of Byte =
    ( 1,1 );
var
  outData56: array[0..6] of Byte;
  key28l: array[0..3] of Byte;
  key28r: array[0..3] of Byte;
  key56o: array[0..6] of Byte;
  i: Integer;
begin
  permutationChoose1(inKey,outData56);

  key28l[0] := outData56[0] shr 4;
  key28l[1] := (outData56[0] shl 4) or (outData56[1] shr 4);
  key28l[2] := (outData56[1] shl 4) or (outData56[2] shr 4);
  key28l[3] := (outData56[2] shl 4) or (outData56[3] shr 4);
  key28r[0] := outData56[3] and $0f;
  key28r[1] := outData56[4];
  key28r[2] := outData56[5];
  key28r[3] := outData56[6];

  for i := 0 to 15 do
  begin
    cycleMove(key28l,bitdisplace[i]);
    cycleMove(key28r,bitdisplace[i]);
    key56o[0] := (key28l[0] shl 4) or (key28l[1] shr 4);
    key56o[1] := (key28l[1] shl 4) or (key28l[2] shr 4);
    key56o[2] := (key28l[2] shl 4) or (key28l[3] shr 4);
    key56o[3] := (key28l[3] shl 4) or (key28r[0]);
    key56o[4] := key28r[1];
    key56o[5] := key28r[2];
    key56o[6] := key28r[3];
    permutationChoose2(key56o,outKey[i]);
  end;
end;

procedure encry(inData,subKey: array of Byte;
   var outData: array of Byte);
var
  outBuf: array[0..5] of Byte;
  buf: array[0..7] of Byte;
  i: Integer;
begin
  expand(inData,outBuf);
  for i := 0 to 5 do outBuf[i] := outBuf[i] xor subKey[i];
  buf[0] := outBuf[0] shr 2;
  buf[1] := ((outBuf[0] and $03) shl 4) or (outBuf[1] shr 4);
  buf[2] := ((outBuf[1] and $0f) shl 2) or (outBuf[2] shr 6);
  buf[3] := outBuf[2] and $3f;
  buf[4] := outBuf[3] shr 2;
  buf[5] := ((outBuf[3] and $03) shl 4) or (outBuf[4] shr 4);
  buf[6] := ((outBuf[4] and $0f) shl 2) or (outBuf[5] shr 6);
  buf[7] := outBuf[5] and $3f;                                
  for i := 0 to 7 do buf[i] := si(i,buf[i]);
  for i := 0 to 3 do outBuf[i] := (buf[i*2] shl 4) or buf[i*2+1];
  permutation(outBuf);
  for i := 0 to 3 do outData[i] := outBuf[i];
end;

procedure desData(desMode: TDesMode;
  inData: array of Byte; var outData: array of Byte);
// inData,outData 都为8Bytes，否则出错
var
  i,j: Integer;
  temp,buf: array[0..3] of Byte;
begin
  for i := 0 to 7 do outData[i] := inData[i];
  initPermutation(outData);
  if desMode = dmEncry then
  begin
    for i := 0 to 15 do
    begin
      for j := 0 to 3 do temp[j] := outData[j];                 //temp = Ln
      for j := 0 to 3 do outData[j] := outData[j + 4];         //Ln+1 = Rn
      encry(outData,subKey[i],buf);                           //Rn ==Kn==> buf
      for j := 0 to 3 do outData[j + 4] := temp[j] xor buf[j];  //Rn+1 = Ln^buf
    end;

    for j := 0 to 3 do temp[j] := outData[j + 4];
    for j := 0 to 3 do outData[j + 4] := outData[j];
    for j := 0 to 3 do outData[j] := temp[j];
  end
  else if desMode = dmDecry then
  begin
    for i := 15 downto 0 do
    begin
      for j := 0 to 3 do temp[j] := outData[j];
      for j := 0 to 3 do outData[j] := outData[j + 4];
      encry(outData,buf);
      for j := 0 to 3 do outData[j + 4] := temp[j] xor buf[j];
    end;
    for j := 0 to 3 do temp[j] := outData[j + 4];
    for j := 0 to 3 do outData[j + 4] := outData[j];
    for j := 0 to 3 do outData[j] := temp[j];
  end;
  conversePermutation(outData);
end;

//////////////////////////////////////////////////////////////

function EncryStr(Str,Key: String): String;
var
  StrByte,OutByte,KeyByte: array[0..7] of Byte;
  StrResult: String;
  I,J: Integer;
begin
  if (Length(Str) > 0) and (Ord(Str[Length(Str)]) = 0) then
    raise Exception.Create('Error: the last char is NULL char.');
  if Length(Key) < 8 then
    while Length(Key) < 8 do Key := Key + Chr(0);
  while Length(Str) mod 8 <> 0 do Str := Str + Chr(0);

  for J := 0 to 7 do KeyByte[J] := Ord(Key[J + 1]);
  makeKey(keyByte,subKey);

  StrResult := '';

  for I := 0 to Length(Str) div 8 - 1 do
  begin
    for J := 0 to 7 do
      StrByte[J] := Ord(Str[I * 8 + J + 1]);
    desData(dmEncry,StrByte,OutByte);
    for J := 0 to 7 do
      StrResult := StrResult + Chr(OutByte[J]);
  end;

  Result := StrResult;
end;

function DecryStr(Str,J: Integer;
begin
  if Length(Key) < 8 then
    while Length(Key) < 8 do Key := Key + Chr(0);

  for I := 0 to Length(Str) div 8 - 1 do
  begin
    for J := 0 to 7 do StrByte[J] := Ord(Str[I * 8 + J + 1]);
    desData(dmDecry,OutByte);
    for J := 0 to 7 do
      StrResult := StrResult + Chr(OutByte[J]);
  end;
  while (Length(StrResult) > 0) and
    (Ord(StrResult[Length(StrResult)]) = 0) do
    Delete(StrResult,Length(StrResult),1);
  Result := StrResult;
end;

///////////////////////////////////////////////////////////

function EncryStrHex(Str,Key: String): String;
var
  StrResult,TempResult,Temp: String;
  I: Integer;
begin
  TempResult := EncryStr(Str,Key);
  StrResult := '';
  for I := 0 to Length(TempResult) - 1 do
  begin
    Temp := Format('%x',[Ord(TempResult[I + 1])]);
    if Length(Temp) = 1 then Temp := '0' + Temp;
    StrResult := StrResult + Temp;
  end;
  Result := StrResult;
end;

function DecryStrHex(StrHex,Key: String): String;
  function HexToInt(Hex: String): Integer;
  var
    I,Res: Integer;
    ch: Char;
  begin
    Res := 0;
    for I := 0 to Length(Hex) - 1 do
    begin
      ch := Hex[I + 1];
      if (ch >= '0') and (ch <= '9') then
        Res := Res * 16 + Ord(ch) - Ord('0')
      else if (ch >= 'A') and (ch <= 'F') then
        Res := Res * 16 + Ord(ch) - Ord('A') + 10
      else if (ch >= 'a') and (ch <= 'f') then
        Res := Res * 16 + Ord(ch) - Ord('a') + 10
      else raise Exception.Create('Error: not a Hex String');
    end;
    Result := Res;
  end;

var
  Str,Temp: String;
  I: Integer;
begin
  Str := '';
  for I := 0 to Length(StrHex) div 2 - 1 do
  begin
    Temp := copy(StrHex,I * 2 + 1,2);
    Str := Str + Chr(HexToInt(Temp));
  end;
  Result := DecryStr(Str,Key);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
//function EncryStrHex(Str,Key: String): String;
//这里的Str表示你要进行加密的字符串，Key表示密钥；
//function DecryStrHex(StrHex,Key: String): String;
//这里的Str表示你要进行解密的字符串，Key表示密钥；
if EncryStrhex(Edit1.Text,'ksaiy')=Edit2.Text then //这里的ksaiy是密钥，你可以设置自己的密钥。
  ShowMessage('注册成功！')
else
  ShowMessage('注册失败！');
///////////////////////////////////////////////////////////////////////////////
                         //Des DEMO V1.0//
                          //作者：ksaiy//
//欢迎使用由ksaiy制作的DES加密算法演示程序，此算法为标准的DES算法，你可以根据的
//的自己需要进行变形。具体怎么操作可以登录我们的网站查询详细的资料。我们专门为软
//件开发者提供软件加密安全测试服务和软件加密解决方案，具体的可以参看我们的网站上
//的资料。
//技术支持:[email protected] 在线QQ：40188696 UC：934155
                            //End //

                  //注意：转载请保留以上信息。//
///////////////////////////////////////////////////////////////////////////////
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Close;
end;

end.