delphi 支持UNICODE的DES加密

//聲明:這個是在網上下載下來之後,加入了UNICODE的處理部份
//在D7和D2010中測試通過
unit U_DES;

interface
uses
SysUtils, Variants,strutils;
type
TKeyByte = array[0..5] of Byte;
TDesMode = (dmEncry, dmDecry);

//加密
function EncryStr(const Str: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;
function EncryStrHex(const Str: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;
//解密
function DecryStr(const Str: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;
function DecryStrHex(StrHex: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): 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, 7, 47, 15, 55, 23, 63, 31,
   38, 6, 46, 14, 54, 22, 62, 30,
   37, 5, 45, 13, 53, 21, 61, 29,
   36, 4, 44, 12, 52, 20, 60, 28,
   35, 3, 43, 11, 51, 19, 59, 27,
   34, 2, 42, 10, 50, 18, 58, 26,
   33, 1, 41, 9, 49, 17, 57, 25,
   32, 0, 40, 8, 48, 16, 56, 24 );

BitExp: array[0..47] of Integer = // 位选择函数E
   ( 31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, 7, 8, 9,10,
   11,12,11,12,13,14,15,16,15,16,17,18,19,20,19,20,
   21,22,23,24,23,24,25,26,27,28,27,28,29,30,31,0 );

BitPM: array[0..31] of Byte = //置换函数P
( 15, 6,19,20,28,11,27,16, 0,14,22,25, 4,17,30, 9,
1, 7,23,13,31,26, 2, 8,18,12,29, 5,21,10, 3,24 );

sBox: array[0..7] of array[0..63] of Byte =    //S盒
   ( ( 14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7,
   0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8,
   4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0,
   15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13 ),

   ( 15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10,
   3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5,
   0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15,
   13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9 ),

   ( 10, 0, 9, 14, 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8,
   13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1,
   13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7,
   1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12 ),

   ( 7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15,
   13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9,
   10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4,
   3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14 ),

   ( 2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9,
   14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6,
   4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14,
   11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3 ),

   ( 12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11,
   10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8,
   9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6,
   4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13 ),

   ( 4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1,
   13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6,
   1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2,
   6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12 ),

   ( 13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7,
   1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2,
   7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8,
   2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11 ) );

BitPMC1: array[0..55] of Byte = //选择置换PC-1
   ( 56, 48, 40, 32, 24, 16, 8,
   0, 57, 49, 41, 33, 25, 17,
   9, 1, 58, 50, 42, 34, 26,
   18, 10, 2, 59, 51, 43, 35,
   62, 54, 46, 38, 30, 22, 14,
   6, 61, 53, 45, 37, 29, 21,
   13, 5, 60, 52, 44, 36, 28,
   20, 12, 4, 27, 19, 11, 3 );

BitPMC2: array[0..47] of Byte =//选择置换PC-2
   ( 13, 16, 10, 23, 0, 4,
   2, 27, 14, 5, 20, 9,
   22, 18, 11, 3, 25, 7,
   15, 6, 26, 19, 12, 1,
   40, 51, 30, 36, 46, 54,
   29, 39, 50, 44, 32, 47,
   43, 48, 38, 55, 33, 52,
   45, 41, 49, 35, 28, 31 );

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

implementation

procedure initPermutation(var inData: array of Byte);
var
newData: array[0..7] of Byte;
i: Integer;
begin
FillChar(newData, 8, 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, 8, 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, 6, 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, 4, 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, 7, 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, 6, 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,2,2, 2,2,2,2, 1,2,2,2, 2,2,2,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, subKey[i], 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;

//////////

ln := Length(KeyBts);
if ln< 8 then
begin
   SetLength(KeyBts, 8);
   for I := ln to 8 do
   KeyBts[I-1] := Byte(0);
end;

ln := Length(StrBts);
lj := ln mod 8;
if lj<>0 then
begin
   SetLength(StrBts, ln + 8-lj);
   for I := ln to ln+8-lj-1 do
   StrBts[I] := Byte(0);
end;

for J := 0 to 7 do
KeyByte[J] := KeyBts[J];
makeKey(keyByte, subKey);

SetLength(BtsResult, Length(StrBts));
for I := 0 to Length(StrBts) div 8 - 1 do
begin
   for J := 0 to 7 do
   StrByte[J] := StrBts[I * 8 + J];
   desData(dmEncry, StrByte, OutByte);
   Move(OutByte[0], BtsResult[8*I], 8);
end;

Result := WideStringOf(BtsResult);
{$ELSE}
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;
{$ENDIF}
end;

if Length(KeyBts) < 8 then
SetLength(KeyBts, 8);

for J := 0 to 7 do
KeyByte[J] := KeyBts[J ];
makeKey(keyByte, subKey);

SetLength(BtsResult, Length(StrBts));
for I := 0 to Length(StrBts) div 8 - 1 do
begin
   for J := 0 to 7 do
   StrByte[J] := StrBts[I * 8 + J];
   desData(dmDecry, StrByte, OutByte);
   Move(OutByte[0], BtsResult[I*8], 8);
end;
Result := WideStringOf(BtsResult);
{$ELSE}
var
StrByte, OutByte, KeyByte: array[0..7] of Byte;
StrResult: String;
I, J: Integer;
begin
if Length(Key) < 8 then
   while Length(Key) < 8 do Key := Key + 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(dmDecry, StrByte, 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;
{$ENDIF}
end;

//////////

Result := StrResult + intToHex(Byte(k),2);
{$ELSE}
var
StrResult, TempResult, Temp: String;
I,k: 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;
k:=0;
for i := 0 to length(StrResult) - 1 do
   k:=k + ord((StrResult[i+1]));

Result := StrResult + intToHex(Byte(k),2);
{$ENDIF}
end;

function DecryStrHex(StrHex: String;const Key: {$IFDEF UNICODE}ANSIString{$ELSE}String{$ENDIF}): String;

function HexToInt(Hex: AnsiString): Integer;
var
   I, Res: Integer;
   ch: AnsiChar;
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;
{$IFDEF UNICODE}
var
Str: String;
Temp: AnsiString;
I,k: Integer;
BtsStr: TBytes;
begin
Str := '';
if Length(StrHex)<=2 then
begin
   Result:='';
   Exit;
end;

K:=0;
for I := 0 to Length(StrHex) - 3 do
   k:=k + ord((StrHex[i+1]));
try
   if Byte(k)<>Byte(strToInt('$' + rightStr(StrHex,2))) then
   begin
   Result:='';
   Exit;
   end;
   Delete(StrHex, Length(StrHex)-1,2);
   SetLength(BtsStr, Length(StrHex) div 2);

   for I := 0 to Length(StrHex) div 2 - 1 do
   begin
   Temp := Copy(StrHex, I * 2 + 1, 2);
   BtsStr[I] := Byte(HexToInt(Temp));
   end;
   Str := WideStringOf(BtsStr);
   Result := DecryStr(Str, Key);
except
   Result:='';
end;
{$ELSE}
var
Str, Temp: String;
I,k: Integer;
begin
Str := '';

if length(StrHex)<=2 then
begin
   result:='';
   exit;
end;
K:=0;
for i := 0 to length(StrHex) - 3 do
   k:=k + ord((StrHex[i+1]));
try
   if Byte(k)<>Byte(strToInt('$' + rightStr(StrHex,2))) then
   begin
   result:='';
   exit;
   end;
   delete(StrHex,length(StrHex)-1,2);

   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);
except
   result:='';
end;
{$ENDIF}
end;

end.

点我访问文章列表

联系电话：

020-00000000

联系电话：

020-00000000

联系电话：

020-12345678