ASP常用类之——DES加密解密类

DES加密是通过密钥（key）加密，密码只能用相同的密钥才能解密的算法。

安全性虽然不是很高，基本满足大部分的应用。

<% Class Cls_DES Private IPRule, CPRule, EPRule, PRule, SBox(7), PCRule(1), MvRule Private K(16), L(16), R(16) Private FillCode, DesStatus Private Sub Class_Initialize() DesStatus = -1 FillCode = "0001101" IPRule = "58,50,42,34,26,18,10,2," &_ "60,52,44,36,28,20,12,4," &_ "62,54,46,38,30,22,14,6," &_ "64,56,48,40,32,24,16,8," &_ "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," CPRule = "40, 8,48,16,56,24,64,32," &_ "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," EPRule = "32, 1, 2, 3, 4, 5," &_ " 4, 5, 6, 7, 8, 9," &_ " 8, 9,10,11,12,13," &_ "12,13,14,15,16,17," &_ "16,17,18,19,20,21," &_ "20,21,22,23,24,25," &_ "24,25,26,27,28,29," &_ "28,29,30,31,32, 1," PRule = "16, 7,20,21,29,12,28,17," &_ " 1,15,23,26, 5,18,31,10," &_ " 2, 8,24,14,32,27, 3, 9," &_ "19,13,30, 6,22,11, 4,25," SBox(0) = "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," SBox(1) = "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," SBox(2) = "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," SBox(3) = " 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," SBox(4) = " 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," SBox(5) = "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," SBox(6) = " 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," SBox(7) = "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," PCRule(0) = "57,49,41,33,25,17, 9," &_ " 1,58,50,42,34,26,18," &_ "10, 2,59,51,43,35,27," &_ "19,11, 3,60,52,44,36," &_ "63,55,47,39,31,23,15," &_ " 7,62,54,46,38,30,22," &_ "14, 6,61,53,45,37,29," &_ "21,13, 5,28,20,12, 4," PCRule(1) = "14,17,11,24, 1, 5, 3,28," &_ "15, 6,21,10,23,19,12, 4," &_ "26, 8,16, 7,27,20,13, 2," &_ "41,52,31,37,47,55,30,40," &_ "51,45,33,48,44,49,39,56," &_ "34,53,46,42,50,36,29,32," MvRule = "1,1,2,2,2,2,2,2,1,2,2,2,2,2,2,1" End Sub Private Function Permute(ByVal Rule, ByVal Text) Dim P_Rule, Num, PText PText = "" P_Rule = Split(Rule, ",") For Each Num In P_Rule Num = Trim(Num) & "" If Num <> "" Then Num = CLng(Num) PText = PText & Mid(Text, Num, 1) End If Next Erase P_Rule Permute = PText End Function Private Function CreateKey() Dim IPKey, C(16), D(16), i, Mv_Rule, MvLen IPKey = Permute(PCRule(0), K(0)) C(0) = Left(IPKey, 28) D(0) = Right(IPKey, 28) Mv_Rule = Split(MvRule, ",") For i = 1 To 16 MvLen = CLng(Trim(Mv_Rule(i - 1))) C(i) = Right(C(i -1), Len(C(i -1)) - MvLen) & Left(C(i -1), MvLen) D(i) = Right(D(i -1), Len(D(i -1)) - MvLen) & Left(D(i -1), MvLen) K(i) = Permute(PCRule(1), C(i) & D(i)) Next End Function Private Function IP(ByVal Text) Dim IPText IPText = Permute(IPRule, Text) L(0) = Left(IPText, 32) R(0) = Right(IPText, 32) IP = IPText End Function Private Function IterativeLR() Dim i For i = 1 To 16 L(i) = R(i - 1) R(i) = B_XOR(L(i - 1), F(R(i - 1), K(i))) Next End Function Private Function F(ByVal RText, ByVal Keys) Dim EPText, XORText, Result, SKey(7), i, x, y Result = "" EPText = Permute(EPRule, RText) XORText = B_XOR(EPText, Keys) For i = 1 To Len(XORText) / 6 SKey(i - 1) = Mid(XORText, (i - 1) * 6 + 1, 6) x = BinaryToDecimal(Left(SKey(i - 1), 1) & Right(SKey(i - 1), 1)) y = BinaryToDecimal(Mid(SKey(i - 1), 2, 4)) SKey(i - 1) = DecimalToBinary(Trim(Split(SBox(i -1), ",")(x * 16 + y))) If Len(SKey(i - 1)) < 4 Then Select Case (4 - Len(SKey(i - 1))) Case 1 SKey(i - 1) = "0" & SKey(i - 1) Case 2 SKey(i - 1) = "00" & SKey(i - 1) Case 3 SKey(i - 1) = "000" & SKey(i - 1) End Select End If Result = Result & SKey(i - 1) Next Result = Permute(PRule, Result) F = Result End Function Private Function B_XOR(ByVal Expression1, ByVal Expression2) Dim E, K, i, XORText XORText = "" E = Trim(Expression1) & "" K = Trim(Expression2) & "" For i = 1 To Len(K) XORText = XORText & CStr(CInt(Mid(E, i, 1)) Xor CInt(Mid(K, i, 1))) Next B_XOR = XORText End Function Private Function BinaryToDecimal(ByVal binNum) Dim Binary, Decimal, i, Length Decimal = 0 Binary = Trim(binNum) & "" If Binary <> "" Then While Left(Binary, 1) = "0" Binary = Right(Binary, Len(Binary) - 1) Wend Length = Len(Binary) For i = 1 To Length Decimal = Decimal + CInt(Mid(Binary, i, 1)) * 2^(Length - i) Next End If BinaryToDecimal = Decimal End Function Private Function DecimalToBinary(ByVal decNum) Dim Decimal, Binary, division Binary = "" Decimal = Trim(decNum) & "" If Decimal <> "" Then Decimal = CLng(Decimal) While Decimal > 1 Binary = Binary & CStr(Decimal Mod 2) Decimal = Decimal / 2 Wend Binary = StrReverse(Binary & Decimal) End If DecimalToBinary = Binary End Function Private Function StrToBinary(ByVal Str) Dim Data, Binary, Text, TextLen, i Text = "" Data = Str For i = 1 To Len(Data) Binary = CStr(DecimalToBinary(Asc(Mid(Data, i, 1)))) If Len(Binary) < 7 Then Select Case (7 - Len(Binary)) Case 1 Binary = "0" & Binary Case 2 Binary = "00" & Binary Case 3 Binary = "000" & Binary Case 4 Binary = "0000" & Binary Case 5 Binary = "00000" & Binary Case 6 Binary = "000000" & Binary End Select End If Text = Text & Binary Next TextLen = Len(Text) If TextLen >= 63 Then If (TextLen Mod 63) <> 0 Then For i = 1 To ((TextLen - TextLen Mod 63) / 7) Text = Text & FillCode Next End If Else For i = 1 To ((63 - TextLen) / 7) Text = Text & FillCode Next End If Binary = Text Text = "" For i = 0 To (Len(Binary) / 63 - 1) Text = Text & Mid(Binary, i * 63 + 1, 63) & "0" Next StrToBinary = Text End Function Private Function BinaryToStr(ByVal binNum) Dim Text, binText, Length, Group, i, j Text = "" binText = Trim(binNum) & "" If binText <> "" Then Length = Len(binText) / 64 - 1 ReDim Group(Length) For i = 0 To Length Group(i) = Left(Mid(binText, i * 64 + 1, 64), 63) Next While Right(Group(Length), 7) = FillCode Group(Length) = Left(Group(Length), Len(Group(Length)) - 7) Wend For i = 0 To Length For j = 1 To Len(Group(i)) / 7 Text = Text & Chr(BinaryToDecimal(Mid(Group(i), (j - 1) * 7 + 1, 7))) Next Next Erase Group End If BinaryToStr = Text End Function Private Function BinaryToHex(ByVal binNum) Dim binText, Text, Length, FillLen, Temp, i Text = "" binText = Trim(binNum) & "" If binText <> "" Then Length = Len(binText) If Length >= 4 Then FillLen = Length Mod 4 Else FillLen = 4 - Length End If Select Case FillLen Case 1 binText = "0" & binText Case 2 binText = "00" & binText Case 3 binText = "000" & binText End Select For i = 0 To (Len(binText) / 4 - 1) Temp = Mid(binText, i * 4 + 1, 4) Select Case Temp Case "0000" Text = Text & "0" Case "0001" Text = Text & "1" Case "0010" Text = Text & "2" Case "0011" Text = Text & "3" Case "0100" Text = Text & "4" Case "0101" Text = Text & "5" Case "0110" Text = Text & "6" Case "0111" Text = Text & "7" Case "1000" Text = Text & "8" Case "1001" Text = Text & "9" Case "1010" Text = Text & "A" Case "1011" Text = Text & "B" Case "1100" Text = Text & "C" Case "1101" Text = Text & "D" Case "1110" Text = Text & "E" Case "1111" Text = Text & "F" End Select Next End If BinaryToHex = Text End Function Private Function HexToBinary(ByVal hexNum) Dim hexText, Text, Temp, i Text = "" hexText = Trim(hexNum) & "" For i = 1 To Len(hexText) Temp = UCase(Mid(hexText, i, 1)) Select Case Temp Case "0" Text = Text & "0000" Case "1" Text = Text & "0001" Case "2" Text = Text & "0010" Case "3" Text = Text & "0011" Case "4" Text = Text & "0100" Case "5" Text = Text & "0101" Case "6" Text = Text & "0110" Case "7" Text = Text & "0111" Case "8" Text = Text & "1000" Case "9" Text = Text & "1001" Case "A" Text = Text & "1010" Case "B" Text = Text & "1011" Case "C" Text = Text & "1100" Case "D" Text = Text & "1101" Case "E" Text = Text & "1110" Case "F" Text = Text & "1111" End Select Next HexToBinary = Text End Function Private Function KeyReverse() Dim Temp, i For i = 1 To 8 Temp = K(i) K(i) = K(16 - i + 1) K(16 - i + 1) = Temp Next End Function Public Function DES(ByVal Data, ByVal Keys, ByVal Work) Dim Text, i, Group, GroupLen Text = Data K(0) = HexToBinary(Keys) If Work = 0 Then Text = StrToBinary(Text) Else Text = HexToBinary(Text) End If GroupLen = Len(Text) / 64 - 1 ReDim Group(GroupLen) For i = 0 To GroupLen Group(i) = Mid(Text, i * 64 + 1, 64) Next Text = "" CreateKey() For i = 0 To GroupLen IP(Group(i)) If Work <> 0 And DesStatus <> 1 Then KeyReverse() DesStatus = 1 ElseIf Work = 0 And DesStatus = 1 Then KeyReverse() DesStatus = 0 End If IterativeLR() Text = Text & Permute(CPRule, R(16) & L(16)) Next Erase Group If Work = 0 Then Text = BinaryToHex(Text) Else Text = BinaryToStr(Text) End If DES = Text End Function End Class %> <% rem 用法示例 'key = "abcd1234567890" '密钥是14位十六进制数（0—9,A,B,C,D,E,F） 'data = "Hello word!" 'Set DesCrypt = New Cls_DES 'Response.Write("原 字 符：" & data & "
") ' 'data_d = DesCrypt.DES(data,key,0) '加密 'Response.Write("加密结果：" & data_d & "
") ' 'data_e = DesCrypt.DES(data_d,key,1) '解密 'Response.Write("解密结果：" & data_e & "
") ' 'Set DesCrypt = Nothing %>