Ksaiy (disappearing in the sea - like Kunming flower) post http://community.9cbs.net/expert/topic/3557/3557236.xml?temp=.9775049
Unit unit1;
Interface
Uses Windows, Messages, Sysutils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Stdctrls;
TYPE TFORM1: TLABEL1: TLABEL; label2: TLabel; edit1: tedit; edit2: tedit; button1: tbutton; button2: tbutton; label3: TLABEL; button3: tbutton; edit3: tedit; edit4: tedit; edit5: tedit Button4: tbutton; procedure button3click (sender: TOBJECT); Procedure Button4Click (Sender: TOBJECT); private {private 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 = // Initial value set 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 = // Inverse initial 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 = // Bit Selection Function 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 = // Replacement function 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 box ((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, 9, 5, 1, 13, 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, 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, 11, 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, 9, 12, 5, 6, 3, 0, 14, 11, 8 , 12, 7, 1, 14, 2, 13, 6, 15, 0, (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, 4, 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 = // Select the replacement PC-1 (56, 48, 40, 32, 24, 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 = // Select the replacement 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 Form1: TForm1; Subkey: Array [0..15] of tKeybyte; importation
{$ R * .dfm}
Procedure InitPermutation (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];
Procedure ConversePermutation (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];
Procedure Expand (Indata: 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); 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];
Function Si (S, Inbyte: Byte): Byte; Var C: Byte; Begin C: = (Inbyte and $ 20) OR 1) OR 1) OR 1) OR 1) OR ((Inbyte and $ 01) SHL 4); Result: = (SBOX [S] [C] and $ 0f);
Procedure Permutationchoose1 (contata: array of byte; var i: integer; begin Fillchar (Outdata, 7, 0); for i: = 0 to 3 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 (contata: array of byte; var); 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))))))
Procedure CYCLEMOVE (VAR INDATA: ARRAY OF 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;
Procedure makeKey (Inkey: array of byte; var outkey); 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 beg 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); var outbuf: array; 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];
Procedure Desdata (Desmode: TDesmode; "VAR OUTDATA: Array Of Byte); // Indata, Outdata is 8Bytes, otherwise 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 for i: = 0 to 15 do begin for i: = 0 to 3 Do Temp [J]: = OUTDATA [J]; // Temp = ln for j: = 0 to 3 do outputa [J]: = OUTDATA [J 4]; // ln 1 = RN Encry (Outdata, Subkey [i], buf); // rn == kN ==> buf for j: = 0 to 3 do outputa [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 outputa [J]: = Temp [J]; 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); fo RJ: = 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);
//
Function EncryStr (STR, Key: String): String; Var strbyte, Outbyte, Keybyte: Array [0..7] of byte; strRRRESULT: STRING; I, J: Inteder; Begin IF (Length (STR)> 0) and (ORD (STR [Length (Str)]) = 0) The Raise Exception.create ('Error: The Last Char is Null Char.'); If Length (KEY) <8 Then While Length <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]);
RESULT: = Strresult;
Function DecryStr (Str, Key: String): String; Var strbyte, Outbyte, Keybyte: Array [0..7] of byte; strRRRESULT: STRING; I, J: Integer; Begin if longth (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 (Strresult [length (strRRRESULT)]) = 0) Do Delete (Strresult, Length), 1); Result: = strRRESULT; END;
///
Function EncryStrhex (Str, Key: String): String; Var Strresult, TempResult, Temp: String; I: Integer; Begin Tempresult: = EncryStr (Str, Key); strRRESULT: = '; for i: = 0 to Length TempResult) - 1 Do Begin Temp: = Format ('% x', [ORD (Tempresult [i 1])]); if longth (TEMP) = 1 Tens: = '0' Temp; strRRRESULT: = Strresult Temp; End; Result: = strRRRESULT; End; Function DecryStrhex (strhex, key: string): string; function hextoint: 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; 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); end; result: = DecryStr (str, key); end;
Call show example:
// Encrypted Procedure TFORM1.BUTTON3CLICK (Sender: TOBJECT); Begin Edit5.Text: = EncryStrhex (Edit3.Text, Edit4.Text);
// Decryption Procedure TFORM1.BUTTON4CLICK (Sender: TOBJECT); begin edit5.text: = DecryStrhex (Edit3.Text, Edit4.Text); END;
End.
