DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);

  FINAL_PERMUTATION (right, work, left);
  WRITE_64BIT_DATA (PChar(_to), right, left);

  Result := 0;
end;

function tripledes_set2keys(ctx: P_tripledes_ctx; key1, key2: PByte): Integer;
var
  I: Integer;
begin
  des_key_schedule (key1, @ctx.encrypt_subkeys);
  des_key_schedule (key2, @(ctx.decrypt_subkeys[32]));

  I := 0;
  while (i < 32) do
  begin
      ctx.decrypt_subkeys[i] := ctx.encrypt_subkeys[30-i];
      ctx.decrypt_subkeys[i+1]  := ctx.encrypt_subkeys[31-i];
      ctx.encrypt_subkeys[i+32] := ctx.decrypt_subkeys[62-i];
      ctx.encrypt_subkeys[i+33] := ctx.decrypt_subkeys[63-i];
      ctx.encrypt_subkeys[i+64] := ctx.encrypt_subkeys[i];
      ctx.encrypt_subkeys[i+65] := ctx.encrypt_subkeys[i+1];
      ctx.decrypt_subkeys[i+64] := ctx.decrypt_subkeys[i];
      ctx.decrypt_subkeys[i+65] := ctx.decrypt_subkeys[i+1];
    Inc(i, 2);
  end;
  Result := 0;
end;

function tripledes_set3keys(ctx: P_tripledes_ctx; key1, key2, key3: PByte): Integer;
var
  I: Integer;
begin
  des_key_schedule (key1, @ctx.encrypt_subkeys);
  des_key_schedule (key2, @(ctx.decrypt_subkeys[32]));
  des_key_schedule (key3, @(ctx.encrypt_subkeys[64]));
  I := 0;
  while (i < 32) do
  begin
    ctx.decrypt_subkeys[i] := ctx.encrypt_subkeys[94-i];
    ctx.decrypt_subkeys[i+1]  := ctx.encrypt_subkeys[95-i];

    ctx.encrypt_subkeys[i+32] := ctx.decrypt_subkeys[62-i];
    ctx.encrypt_subkeys[i+33] := ctx.decrypt_subkeys[63-i];

    ctx.decrypt_subkeys[i+64] := ctx.encrypt_subkeys[30-i];
    ctx.decrypt_subkeys[i+65] := ctx.encrypt_subkeys[31-i];
    Inc(i, 2);
  end;
  Result := 0;
end;

procedure tripledes_ecb_crypt(ctx: P_tripledes_ctx; const _from: PByte; _to: PByte; mode: Integer);
var
  left, right, work: DWORD;
  keys: PDWORD;
  data: PChar;
begin
  if mode <> 0 then keys := @ctx.decrypt_subkeys
  else keys := @ctx.encrypt_subkeys;

  data := PChar(_from);
  READ_64BIT_DATA (data, left, right);
  INITIAL_PERMUTATION (left, work, right);

  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);

  DES_ROUND(left, right, work, keys); DES_ROUND(right, left, work, keys);
  DES_ROUND(left, right, work, keys); DES_ROUND(right, left, work, keys);
  DES_ROUND(left, right, work, keys); DES_ROUND(right, left, work, keys);
  DES_ROUND(left, right, work, keys); DES_ROUND(right, left, work, keys);
  DES_ROUND(left, right, work, keys); DES_ROUND(right, left, work, keys);
  DES_ROUND(left, right, work, keys); DES_ROUND(right, left, work, keys);
  DES_ROUND(left, right, work, keys); DES_ROUND(right, left, work, keys);
  DES_ROUND(left, right, work, keys); DES_ROUND(right, left, work, keys);

  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);
  DES_ROUND(right, left, work, keys); DES_ROUND(left, right, work, keys);

  FINAL_PERMUTATION (right, work, left);
  WRITE_64BIT_DATA (PChar(_to), right, left);
end;

function is_weak_key(const key: PByte): Integer;
var
  I, left, right, middle, cmp_result: Integer;
  work: array [0..7] of Byte;
  _key: PChar;
begin
  _key := PChar(key);
  for i := 0 to 7 do work[i] := Byte(_key[i]) and $fe;

  left := 0; right := 63;
  while(left <= right) do
  begin
    middle := (left + right) div 2;
    cmp_result := working_memcmp(PChar(@work[0]), PChar(@weak_keys[middle]), 8);
    if (cmp_result <> 0) then
    begin
      Result := -1;
      Exit;
    end;
    if (cmp_result > 0) then left := middle + 1
    else right := middle - 1;
  end;
  Result := 0;
end;

function memcmp(const a, b; n: Integer): Boolean;
var
  _a, _b: PChar;
  I: Integer;
begin
  Result := False;
  _a := @a; _b := @b;
  for I := 0 to n do
  begin
    if (_a^ <> _b^) then
    begin
      Result := False;
      Exit;
    end else Result := True;
  end;
end;

procedure DO_PERMUTATION(var a, temp, b: DWORD; const offset, mask: DWORD);
begin
  temp := ((a shr offset) xor b) and mask;
  b := temp xor b;
  a := (temp shl offset) xor a;
end;

procedure INITIAL_PERMUTATION(var left, temp, right: DWORD);
begin
  DO_PERMUTATION(left, temp, right, 4, $0f0f0f0f);
  DO_PERMUTATION(left, temp, right, 16, $0000ffff);
  DO_PERMUTATION(right, temp, left, 2, $33333333);
  DO_PERMUTATION(right, temp, left, 8, $00ff00ff);
  DO_PERMUTATION(left, temp, right, 1, $55555555);
end;

procedure FINAL_PERMUTATION(var left, temp, right: DWORD);
begin
  DO_PERMUTATION(left, temp, right, 1, $55555555);
  DO_PERMUTATION(right, temp, left, 8, $00ff00ff);
  DO_PERMUTATION(right, temp, left, 2, $33333333);
  DO_PERMUTATION(left, temp, right, 16, $0000ffff);
  DO_PERMUTATION(left, temp, right, 4, $0f0f0f0f);
end;

procedure DES_ROUND(var _from, _to, work: DWORD; var subkey: PDWORD);
begin
  work := ((_from shl 1) or (_from shr 31)) xor subkey^; Inc(subkey);
  _to := _to xor (sbox8[work and $3f]);
  _to := _to xor (sbox6[(work shr 8) and $3f]);
  _to := _to xor (sbox4[(work shr 16) and $3f]);
  _to := _to xor (sbox2[(work shr 24) and $3f]);

  work := ((_from shr 3) or (_from shl 29)) xor subkey^; Inc(subkey);
  _to := _to xor (sbox7[work and $3f]);
  _to := _to xor (sbox5[(work shr 8) and $3f]);
  _to := _to xor (sbox3[(work shr 16) and $3f]);
  _to := _to xor (sbox1[(work shr 24) and $3f]);
end;

procedure READ_64BIT_DATA(var data: PChar; var left, right: DWORD);
begin
  left := (DWORD(Byte(data[0]) shl 24)) or  (DWORD(Byte(data[1]) shl 16))
    or (DWORD(Byte(data[2]) shl 8) or (DWORD(Byte(data[3]))));
  right := (DWORD(Byte(data[4]) shl 24)) or  (DWORD(Byte(data[5]) shl 16))
    or (DWORD(Byte(data[6]) shl 8) or (DWORD(Byte(data[7]))));
end;

procedure WRITE_64BIT_DATA(var data: PChar; left, right: DWORD);
begin
  data[0] := Char((left shr 24) and $ff);
  data[1] := Char((left shr 16) and $ff);
  data[2] := Char((left shr 8) and $ff);
  data[3] := Char(left and $ff);
  data[4] := Char((right shr 24) and $ff);
  data[5] := Char((right shr 16) and $ff);
  data[6] := Char((right shr 8) and $ff);
  data[7] := Char(right and $ff);
end;

function selftest(): string;
const
  key: array [0..7] of Byte = ($55, $55, $55,$55, $55, $55, $55, $55);
  input: array [0..7] of Byte = ($FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF);
  aresult: array [0..7] of Byte = ($24, $6e, $9d, $b9, $c5, $50, $38, $1a);
var
  I: Integer;
  temp1, temp2, temp3: array [0..7] of Byte;
  des: _des_ctx;
begin
  for I := 0 to 63 do
  begin
    des_setkey (@des, @key);
    des_ecb_crypt (@des, @input, @temp1, 0);
    des_ecb_crypt (@des, @temp1, @temp2, 0);
    des_setkey (@des, @temp2);


des_ecb_crypt (@des, @temp1, @temp3, 1);
    CopyMemory(@key, @temp3, 8);
    CopyMemory(@input, @temp1, 8);
  end;
  if not (memcmp (temp3, aresult, 8)) then
    Result := 'DES maintenance test failed.'
  else
    Result := 'DES ok';
end;

function selftest3(): string;
const
  input3: array [0..7] of Byte = ($fe, $dc, $ba, $98, $76, $54, $32, $10);
  key1: array [0..7] of Byte = ($12, $34, $56, $78, $9a, $bc, $de, $f0);
  key2: array [0..7] of Byte = ($11, $22, $33, $44, $ff, $aa, $cc, $dd);
  result3: array [0..7] of Byte = ($7b, $38, $3b, $23, $a2, $7d, $26, $d3);
var
  des3: _tripledes_ctx;
  I: Integer;
begin
  for I := 0 to 15 do
  begin
    tripledes_set2keys (@des3, @key1, @key2);
    tripledes_ecb_crypt (@des3, @input3, @key1, 0);
    tripledes_ecb_crypt (@des3, @input3, @key2, 1);
    tripledes_set3keys (@des3, @key1, @input3, @key2);
    tripledes_ecb_crypt (@des3, @input3, @input3, 0);
  end;
  if not (memcmp (input3, result3, 8)) then
      Result := 'TRIPLE-DES test failed.'
  else
    Result := 'TRIPLE-DES ok';
end;

end.

------------
//測試
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(selftest());
  ShowMessage(selftest3());
end;

function DES_EnCrypt(const aStr, acKey: string): string;
var
  key, work_temp, temp1, temp2, temp3: array [0..7] of Byte;
  work_s, key_s: string;
  I, iLen, J: Integer;
  des: _des_ctx;
begin
  Result := '';
  if (aStr = '') or (acKey = '') then Exit;
  iLen := Length(aStr);
  work_s := aStr;
  if (iLen mod 8) <> 0 then
  begin
    SetLength(work_s, iLen + (8 - iLen mod 8));
    FillMemory(@work_s[iLen + 1], 8 - iLen mod 8, 0);
    iLen := Length(work_s);
  end;
  for J := 1 to iLen div 8 do
  begin
    key_s := Copy(acKey, 1, 8);
    CopyMemory(@key, @key_s[1], Length(key_s));
    FillMemory(@key[Length(key_s)], 8 - Length(key_s), 0);
    CopyMemory(@work_temp, @work_s[J * 8 -7], 8);
    for I := 0 to 63 do
    begin
      des_setkey (@des, @key);
      des_ecb_crypt (@des, @work_temp, @temp1, 0);
      des_ecb_crypt (@des, @temp1, @temp2, 0);
      des_setkey (@des, @temp2);
      des_ecb_crypt (@des, @temp1, @temp3, 1);
      CopyMemory(@key, @temp3, 8);
      CopyMemory(@work_temp, @temp1, 8);
    end;
    for I := 0 to 7 do
    begin
      Result := Result + Format('%.2X', [temp3[I]]);// Chr(temp3[I]);
    end;
  end;
end;