unit1.~pas

des 3des加密delphi例子；标准的des,3des算法

  Result := True;
end;

function TForm1.FillToEightBits(var sz: string): Boolean;
var
  Temp:array[0..7] of Char;
  i,j,k:Integer;
  re:Boolean;
begin
     //length less than 8 , add zero(s) to tail
  re:=True;
	FillChar(Temp,SizeOf(Temp),$0);
  for i:=1 to Length(sz)do  //把SZ的内容存储到临时数组中
  begin
    Temp[i-1] := sz[i];
  end;
  j:=Length(sz)+1;
  while j<9 do        //增加SZ长度
  begin
    sz := sz+char('0');
    Inc(j);
  end;
  for k:=1 to 8 do   //把数组中的字符全部给SZ，相当于不足的填0
  begin
    sz[k] := Temp[k-1];
  end;
  Result :=re;
end;
function TForm1.GetCiphertextAnyLength: string;
begin
  Result := szFCiphertextAnyLength;
end;

function TForm1.InitialPermuteData(s: string; var sz: array of Char;
  szBool: Boolean): Boolean;
var
  sz_64Data:array[0..63]of  Char;
  iTmpBit:array[0..63]of Integer;
  sz_IPData:array[0..63] of Char;
  iCnt,iPst,_i,ui:Integer;
  DeStr:string;
  ch:Char;
begin
  FillChar(sz_64Data,SizeOf(sz_64Data),$0);
  FillChar(sz_IPData,SizeOf(sz_IPData),$0);
  FillChar(iTmpBit,SizeOf(iTmpBit),0);
  if szBool then    //加密
  begin
		//把8byte（64位）的string转换为2进制的位数组
    for iCnt :=0 to 63 do
      iTmpBit[iCnt] := (Ord(s[1+(iCnt shr 3)])shr(iCnt and 7))and 1;
    for iCnt :=0 to 7 do
    begin
     for iPst :=0 to 7 do
     begin
       sz_64Data[8*iCnt+iPst] := SingleBinaryToChar(iTmpBit[8*(iCnt+1)-(iPst+1)]);
     end;
    end;
    //IP置换
//    for _i := 0 to 63 do
    _i := 0;
    while _i<64 do
    begin
      sz_IPData[_i] := sz_64Data[IP_Table[_i]-1];
//      Inc(i);
      _i := _i+1;
    end;

  end
  else   //解密
  begin
    for ui:=0 to (Length(s)-1) do
    begin
      ch := s[ui+1];
      DeStr := DeStr+HexCharToBinary(LowerCase(ch)[1]);
    end;
    for _i:=0 to 63 do
    begin
      sz_IPData[_i] := DeStr[IP_Table[_i]];
    end;
  end;

  CopyMemory(@sz,@sz_IPData,Length(sz_IPData));
  Result := True;

end;

procedure TForm1.FunctionF(var sz_Li1, sz_Ri1: array of Char;bIsUseSecondKey:Boolean;iKey: Integer);
var
  sz_48R,sz_xor48,sz_Key:array[0..47]of Char;
  sz_P32,sz_Rii:array[0..31]of Char;
  s_Compress32:string;
begin
  FillChar(sz_48R,SizeOf(sz_48R),$0);
  FillChar(sz_xor48,SizeOf(sz_xor48),$0);
  FillChar(sz_Key,SizeOf(sz_Key),$0);
  FillChar(sz_P32,SizeOf(sz_P32),$0);
  FillChar(sz_Rii,SizeOf(sz_Rii),$0);
  if bIsUseSecondKey then
    CopyMemory(@sz_Key,@SubKeys2[iKey],48)

  else
    CopyMemory(@sz_Key,@SubKeys[iKey],48);
  ExpansionR(sz_Ri1,sz_48R);     //将右32位扩展为48位
  ExecXOR(sz_48R,sz_Key,48,sz_xor48);  //与16组密钥的一组进行异或

  s_Compress32 := CompressFuncS(sz_xor48); //分解为8个6位长 并按S表置换

  PermutationP(s_Compress32,sz_P32); // 按IP逆置换

  ExecXOR(sz_P32,sz_Li1,32,sz_Rii);  //于左部分异或放在右部分
  CopyMemory(@sz_Li1,@sz_Ri1,32);    //交换左右部分
  CopyMemory(@sz_Ri1,@sz_Rii,32);
end;

procedure TForm1.ExpansionR(var rsData,deData: array of  Char);
var
  sz_48ER :array[0..47]of Char;
  ii:Integer;
begin

  FillChar(sz_48ER,SizeOf(sz_48ER),$0);

  ii := 0;
  while  ii<48 do //for ii:=0 to 47 do
  begin
    sz_48ER[ii]:= rsData[E_Table[ii]-1];
    ii:=ii+1;

  end;
  CopyMemory(@deData,@sz_48ER,48);
end;

procedure TForm1.ExecXOR(sz_P1, sz_P2: array of Char; len: Integer;
  var Return_value: array of Char);

var
  sz_Buffer :array[0..255] of Char;
  i:Integer;
begin
  FillChar(sz_Buffer,SizeOf(sz_Buffer),$0);
  for i:=0 to len-1 do
  begin
    sz_Buffer[i] := SingleBinaryToChar(SingleCharToBinary(sz_P1[i]) xor SingleCharToBinary(sz_P2[i]))
  end;
  CopyMemory(@Return_value,@sz_Buffer,len);

end;

function TForm1.SingleCharToBinary(ch: Char): Integer;
begin
  if(ch = '1') then
    Result:= 1
  else
    Result:= 0;
end;

function TForm1.CompressFuncS(sz_48: array of Char): string;
var
  sTmp:array[0..7,0..5]of Char;
  sz_32:string;
  i,j:Integer;
  iX,iY:Integer;
begin
  FillChar(sTmp,SizeOf(sTmp),$0);

  for i:=0 to 7 do
  begin
    CopyMemory(@sTmp[i],@sz_48[6*i],6);
    iX := SingleCharToBinary(sTmp[i][0])*2+SingleCharToBinary(sTmp[i][5]);
    iY := 0;
    for j:=1 to 4 do
      iY := iY+ SingleCharToBinary(sTmp[i][j]) * MyPower(2,4-j);
    sz_32 := sz_32+HexIntToBinary(S_Box[i][iX][iY]);
  end;
  Result := sz_32;
end;

procedure TForm1.PermutationP(s: string; var Return_value: array of Char);
var
  sz_32bits :array[0..31] of Char;
  i:Integer;
begin
  FillChar(sz_32bits,SizeOf(sz_32bits),$0);
//  for i:=0 to 31 do
  i:=0;
  while i<32 do
  begin
    sz_32bits[i]:=s[Ord(P_Table[i])];
    i:=i+1;
  end;
  CopyMemory(@Return_value,@sz_32bits,32);
end;

function TForm1.HexIntToBinary(i: Integer): string;
begin
  case i of
    0:result := '0000';
    1:result := '0001';
    2:result := '0010';
    3:result := '0011';
    4:result := '0100';
    5:result := '0101';
    6:result := '0110';
    7:result := '0111';
    8:result := '1000';
    9:result := '1001';
    10:result := '1010';
    11:result := '1011';
    12:result := '1100';
    13:result := '1101';
    14:result := '1110';
    15: result := '1111';
    else result := '';
  end;

end;

function TForm1.MyPower(base, Exponent: Integer): Integer;
begin
 if Exponent = 0 then
    Result := 1               { n**0 = 1 }
  else if (Base = 0) and (Exponent > 0) then
    Result := 0              { 0**n = 0, n > 0 }
  else if (Frac(Exponent) = 0) and (Abs(Exponent) <= MaxInt) then
    Result := StrToInt(FloatToStr(IntPower(Base, Integer(Trunc(Exponent)))))
  else
    Result := StrToInt(FloatToStr(Exp(Exponent * Ln(Base))));
end;

function TForm1.BinaryToString(szSource: array of Char; len: Integer;
  bType: Boolean): string;
var
  ilen,i,j,iCh:Integer;
  s_return,tmpS:string;
  szTmp8:array[0..7]of Char;
  buffer:array[0..15]of Char;
  cTmp,ch:Char;
begin
        //bType == true is Binary to Hex
        //else is Binary to Char
  FillChar(szTmp8,SizeOf(szTmp8),$0);
  FillChar(buffer,SizeOf(buffer),$0);

  ilen := 0;
  if (len mod 8)<>0 then
  begin
    Result := Char($0);
  end
  else
    ilen := Trunc(len/8);
  s_return := '';
  for i:=0 to ilen-1 do
  begin
    iCh :=0;
    CopyMemory(@szTmp8,@szSource[8*i],8);
    for j:=0 to 7 do
    begin

      iCh := iCh+SingleCharToBinary(szTmp8[j]) * MyPower(2,7-j);
    end;
    if bType then
    begin
      if iCh>$F then
        tmpS := LowerCase(IntToHex(iCh,2))
      else
        tmpS := LowerCase(IntToHex(iCh,1));
      CopyMemory(@buffer,PChar(tmpS),Length(tmpS));
//      itoa(iCh,buffer,16);
      if iCh <16 then
      begin
        cTmp := buffer[0];
        buffer[0] := Char('0');
        buffer[1] := cTmp;
      end;
      s_return := s_return+buffer[0];
      s_return := s_return+buffer[1];
      buffer[0]:= Char($0);
      buffer[1]:= Char($0);
    end
    else
    begin
      ch := Char(iCh);
      s_return := s_return+ch;
    end;
  end;
  Result := s_return;
end;

function TForm1.DecryptAnyLength(sHexData:string;bIsUseSecondKey:Boolean): Boolean;
var
  iLength,iParts,iResidue,i:Integer;
  szTmp:string;

begin
  iLength := Length(sHexData);   //求得数组的有效长度
//  iRealLengthOfPlaintext := 0;
  //if the length is 16 , call DecyptData
  if iLength = 16 then
  begin
    DecryptData(sHexData,bIsUseSecondKey,true);
    CopyMemory(@szFPlaintextAnyLength,@szPlaintext,8);
//    iRealLengthOfPlaintext := 8;
  end
  else
  if iLength<16 then
  begin
     //printf(szFPlaintextAnyLength,"待解密字符长度必须为16的倍数！")
  end
  else
  if iLength>16 then
  begin
    iParts := Ceil(iLength/16.0);
    iResidue := iLength mod 16;
    if iResidue <>0 then
    begin
//                        sprintf(szFPlaintextAnyLength,"待解密字符长度必须为16的倍数！");

    end;
//    iRealLengthOfPlaintext := iParts*8;
    for i:=0 to iParts-1 do
    begin
      szTmp := copy(sHexData,(i*16)+1,16);
      DecryptData(szTmp,bIsUseSecondKey,true);
      CopyMemory(@szFPlaintextAnyLength[8*i],@szPlaintext,8);
    end;

  end;
  Result := True;
//  CleanPlaintextMark(iRealLengthOfPlaintext);//清理末尾的美元符，这个应该用不上了
end;

function TForm1.DecryptData(s: string;bIsUseSecondKey,bDecryptHex:Boolean): Boolean;
var
  sz_IP:array[0..63]of Char;
  sz_Li:array[0..31]of Char;
  sz_Ri:array[0..31]of Char;
  sz_Final64:array[0..63]of Char;
  szPlaintextBinary:array[0..63]of Char;
  i:Integer;
begin
  Result := False;
  FillChar(sz_IP,SizeOf(sz_IP),$0);
  FillChar(sz_Li,SizeOf(sz_Li),$0);
  FillChar(sz_Ri,SizeOf(sz_Ri),$0);
  FillChar(sz_Final64,SizeOf(sz_Final64),$0);
  FillChar(szPlaintextBinary,SizeOf(szPlaintextBinary),$0);
  //IP --- return is sz_IP
  InitialPermuteData(s,sz_IP,not bDecryptHex);
        //divide the 64 bits data to two parts
  CopyMemory(@sz_Ri,@sz_IP,32);
  CopyMemory(@sz_Li,@sz_IP[32],32);
        //16 rounds F and xor and exchange
  for i:=0 to 15 do
    FunctionF(sz_Ri,sz_Li,bIsUseSecondKey,15-i);
        //the round 16 will not exchange L and R
  CopyMemory(@sz_Final64,@sz_Li,32);
  CopyMemory(@sz_Final64[32],@sz_Ri,32);
        // ~IP
  for i:=0 to 63 do
    szPlaintextBinary[i] := sz_Final64[Ord(IPR_Table[i])-1];
  CopyMemory(@szPlaintext,PChar(BinaryToString(szPlaintextBinary,64,false)),8);
  Result := True;
end;


procedure TForm1.btn4Click(Sender: TObject);
begin
  DecryptAnyLength(edt5.Text,False);
  edt4.text := szFPlaintextAnyLength;
end;

function  TForm1.HexCharToBinary(ch:Char):string;
begin
   case ch of

    '0':Result:= '0000';
    '1':Result:= '0001';
    '2':Result:= '0010';
    '3':Result:= '0011';
    '4':Result:= '0100';
    '5':Result:= '0101';
    '6':Result:= '0110';
    '7':Result:= '0111';
    '8':Result:= '1000';
    '9':Result:= '1001';
    'a':Result:= '1010';
    'b':Result:= '1011';
    'c':Result:= '1100';
    'd':Result:= '1101';
    'e':Result:= '1110';
    'f':Result:= '1111';
    else  Result:= '';
   end;
end;
procedure TForm1.btn2Click(Sender: TObject);
begin
  edt4.Text := '';
  InitializeKey(Trim(edt1.Text),False);
  InitializeKey(Trim(edt2.Text),True);
  TripleEncryptAnyLength(Trim(edt3.Text));
  edt5.Text := GetCiphertextAnyLength();
  
end;

procedure TForm1.TripleEncryptAnyLength(szSource: string);
var
  TmpStr:string;
begin
  //E(key1)-D(key2)-E(key1)
  EncryptAnyLength(szSource,false);
  TmpStr := szFCiphertextAnyLength;
  DecryptAnyLength(TmpStr,True);
  EncryptAnyLength(szFPlaintextAnyLength,False);

end;

procedure TForm1.TripleDecryptAnyLength(szSource: string);
var
  TmpStr,TmpStr1:string;
begin
  //D(key1)-E(key2)-D(key1)
  DecryptAnyLength(szSource,false);
  TmpStr := szFPlaintextAnyLength;
  EncryptAnyLength(TmpStr,true);
  TmpStr1 := szFCiphertextAnyLength;
  DecryptAnyLength(TmpStr1,false);
end;

procedure TForm1.btn5Click(Sender: TObject);
var
  myDesCls:TDes3DesCls;
begin
  myDesCls := TDes3DesCls.CreateDESCls;
  myDesCls.EncryptDES(edt1.Text,edt3.Text);

end;

end.