執行結果：
27B827277C70E88DD87E3057BFBE8F
<%
'********************************************************************************
'* *
'* CFS Encode Function *
'* *
'* Produced by ASP-Zone *
'* *
'* Main website is located at *
'* http://asp.diy.com.tw/ *
'* *
'* E-MAIL: *
'* thiefghost@games.com.tw *
'* *
'* Use this function: *
'* <!--#include file="Codefun.fun" --> *
'* *
'* 2001/8/3 *
'* *
'********************************************************************************
'Encode Function
Function CfsEnCode(CodeStr)
Dim CodeLen
Dim CodeSpace
Dim NewCode
CodeLen = 30
CodeSpace = CodeLen - Len(CodeStr)
If Not CodeSpace < 1 Then
For cecr = 1 To CodeSpace
CodeStr = CodeStr & Chr(21)
Next
End If
NewCode = 1
Dim Been
For cecb = 1 To CodeLen
Been = CodeLen + Asc(Mid(CodeStr,cecb,1)) * cecb
NewCode = NewCode * Been
Next
CodeStr = NewCode
NewCode = Empty
For cec = 1 To Len(CodeStr)
NewCode = NewCode & CfsCode(Mid(CodeStr,cec,3))
Next
For cec = 20 To Len(NewCode) - 18 Step 2
CfsEnCode = CfsEnCode & Mid(NewCode,cec,1)
Next
End Function
Function CfsCode(Word)
For cc = 1 To Len(Word)
CfsCode = CfsCode & Asc(Mid(Word,cc,1))
Next
CfsCode = Hex(CfsCode)
End Function
%>
作者: hjb016 时间: 2010-10-19 17:01 2-RC4经典加密算法VB版本代码
VB版rc4算法
Public Sub main()
Dim key As String
For i = 1 To 16
Randomize
key = key & Chr(Rnd * 255)
Next i
MsgBox RC4(RC4("Welcome To Plindge Studio!", key), key)
End Sub
Public Function RC4(inp As String, key As String) As String
Dim S(0 To 255) As Byte, K(0 To 255) As Byte, i As Long
Dim j As Long, temp As Byte, Y As Byte, t As Long, x As Long
Dim Outp As String
For i = 0 To 255
S(i) = i
Next
j = 1
For i = 0 To 255
If j > Len(key) Then j = 1
K(i) = Asc(Mid(key, j, 1))
j = j + 1
Next i
j = 0
For i = 0 To 255
j = (j + S(i) + K(i)) Mod 256
temp = S(i)
S(i) = S(j)
S(j) = temp
Next i
i = 0
j = 0
For x = 1 To Len(inp)
i = (i + 1) Mod 256
j = (j + S(i)) Mod 256
temp = S(i)
S(i) = S(j)
S(j) = temp
t = (S(i) + (S(j) Mod 256)) Mod 256
Y = S(t)
Outp = Outp & Chr(Asc(Mid(inp, x, 1)) Xor Y)
Next
RC4 = Outp
End Function
Function test_MD5()
'引用 ComMD5 1.0 Type Library
'该类库定位于 msppmd5.dll
Dim a As New CoMD5
Debug.Print a.MD5Hash("a")
Debug.Print a.MD5Hash("a")
End Function
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function md5_F(x, y, z)
md5_F = (x And y) Or ((Not x) And z)
End Function
Private Function md5_G(x, y, z)
md5_G = (x And z) Or (y And (Not z))
End Function
Private Function md5_H(x, y, z)
md5_H = (x Xor y Xor z)
End Function
Private Function md5_I(x, y, z)
md5_I = (y Xor (x Or (Not z)))
End Function
Private Sub md5_FF(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_GG(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_HH(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_II(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Private Function WordToHex(lValue)
Dim lByte
Dim lCount
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
For k = 0 To UBound(x) Step 16
AA = a
BB = b
CC = c
DD = d
md5_FF a, b, c, d, x(k + 0), S11, &HD76AA478
md5_FF d, a, b, c, x(k + 1), S12, &HE8C7B756
md5_FF c, d, a, b, x(k + 2), S13, &H242070DB
md5_FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
md5_FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
md5_FF d, a, b, c, x(k + 5), S12, &H4787C62A
md5_FF c, d, a, b, x(k + 6), S13, &HA8304613
md5_FF b, c, d, a, x(k + 7), S14, &HFD469501
md5_FF a, b, c, d, x(k + 8), S11, &H698098D8
md5_FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
md5_FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
md5_FF b, c, d, a, x(k + 11), S14, &H895CD7BE
md5_FF a, b, c, d, x(k + 12), S11, &H6B901122
md5_FF d, a, b, c, x(k + 13), S12, &HFD987193
md5_FF c, d, a, b, x(k + 14), S13, &HA679438E
md5_FF b, c, d, a, x(k + 15), S14, &H49B40821
md5_GG a, b, c, d, x(k + 1), S21, &HF61E2562
md5_GG d, a, b, c, x(k + 6), S22, &HC040B340
md5_GG c, d, a, b, x(k + 11), S23, &H265E5A51
md5_GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
md5_GG a, b, c, d, x(k + 5), S21, &HD62F105D
md5_GG d, a, b, c, x(k + 10), S22, &H2441453
md5_GG c, d, a, b, x(k + 15), S23, &HD8A1E681
md5_GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
md5_GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
md5_GG d, a, b, c, x(k + 14), S22, &HC33707D6
md5_GG c, d, a, b, x(k + 3), S23, &HF4D50D87
md5_GG b, c, d, a, x(k + 8), S24, &H455A14ED
md5_GG a, b, c, d, x(k + 13), S21, &HA9E3E905
md5_GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
md5_GG c, d, a, b, x(k + 7), S23, &H676F02D9
md5_GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
md5_HH a, b, c, d, x(k + 5), S31, &HFFFA3942
md5_HH d, a, b, c, x(k + 8), S32, &H8771F681
md5_HH c, d, a, b, x(k + 11), S33, &H6D9D6122
md5_HH b, c, d, a, x(k + 14), S34, &HFDE5380C
md5_HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
md5_HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
md5_HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
md5_HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
md5_HH a, b, c, d, x(k + 13), S31, &H289B7EC6
md5_HH d, a, b, c, x(k + 0), S32, &HEAA127FA
md5_HH c, d, a, b, x(k + 3), S33, &HD4EF3085
md5_HH b, c, d, a, x(k + 6), S34, &H4881D05
md5_HH a, b, c, d, x(k + 9), S31, &HD9D4D039
md5_HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
md5_HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
md5_HH b, c, d, a, x(k + 2), S34, &HC4AC5665
md5_II a, b, c, d, x(k + 0), S41, &HF4292244
md5_II d, a, b, c, x(k + 7), S42, &H432AFF97
md5_II c, d, a, b, x(k + 14), S43, &HAB9423A7
md5_II b, c, d, a, x(k + 5), S44, &HFC93A039
md5_II a, b, c, d, x(k + 12), S41, &H655B59C3
md5_II d, a, b, c, x(k + 3), S42, &H8F0CCC92
md5_II c, d, a, b, x(k + 10), S43, &HFFEFF47D
md5_II b, c, d, a, x(k + 1), S44, &H85845DD1
md5_II a, b, c, d, x(k + 8), S41, &H6FA87E4F
md5_II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
md5_II c, d, a, b, x(k + 6), S43, &HA3014314
md5_II b, c, d, a, x(k + 13), S44, &H4E0811A1
md5_II a, b, c, d, x(k + 4), S41, &HF7537E82
md5_II d, a, b, c, x(k + 11), S42, &HBD3AF235
md5_II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
md5_II b, c, d, a, x(k + 9), S44, &HEB86D391
a = AddUnsigned(a, AA)
b = AddUnsigned(b, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next
MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
' MD5=LCase(WordToHex(b) & WordToHex(c)) 'I crop this to fit 16byte database password
End Function
' Base64 Encode/Decode
'
' This is an optimized version of the common Base 64 encode/decode.
' This version eliminates the repeditive calls to chr$() and asc(),
' as well as the linear searches I've seen in some routines.
'
' This method does use a bit more memory in permanent lookup tables
' than most do. However, this eliminates the need for using vb's
' rather slow method of bit shifting (multiplication and division).
' This appears not to make much difference in the IDE, but make
' a huge difference in the exe.
' Encodeing Index = 834 vs. 64 bytes standard
' Decoding Index = 1536 vs. 64 to 256 standard
'
' This routine also adds the CrLf on the fly rather than making
' a temporary copy of the encoded string then adding the crlf
'
' Encoding/Decoding data from and to a file should be changed to
' use a fixed buffer to reduce the memory requirements of EncodeFile, etc.
'
' All of this results in a speed increase:
' Encode:
' 100 reps on a string of 28311 bytes
' IDE EXE
' Base64 2824 300 (220 w/no overflow & array bound checks)
' Base64a (unknown author) 375500* 185300*
' Base64b (Wil Johnson) 2814 512 (410 w/no overflow & array bound checks)
' *Extrapolated (based on 1 rep, I didn't have time to wait 30 minutes for 100)
' *Unknown code is from ftp:altecdata.com/base64.cls
'
' Decode
' 100 reps on a string of 28311 bytes
' IDE EXE
' Base64 3384 351 (271 w/no overflow & array bound checks)
' Base64a (unknown author)
' Base64b (Wil Johnson) 5969 1191 (981 w/no overflow & array bound checks)
' *Failed
' *Unknown code is from ftp:altecdata.com/base64.cls
'
'
'
' This code is provided as-is. You are free to use and modify it
' as you wish. Please report bugs, fixes and enhancements to the
' author.
'
' 用如下方法使用:
' Dim b as Base64
' b = New Base64
' Debug.Print b.Encode("This is a test.") ' Prints "VGhpcyBpcyBhIHRlc3Qu"
' Debug.Print b.Decode("VGhpcyBpcyBhIHRlc3Qu") ' Prints "This is a test."
'
'
'建立一个类模块，然后输入这段代码
Private Const MAX_LINELENGTH As Long = 76 ' Must be a multiple of 4
Private Const CHAR_EQUAL As Byte = 61
Private Const CHAR_CR As Byte = 13
Private Const CHAR_LF As Byte = 10
Private m_Index1(0 To 255) As Byte
Private m_Index2(0 To 255) As Byte
Private m_Index3(0 To 255) As Byte
Private m_Index4(0 To 63) As Byte
Private m_ReverseIndex1(0 To 255) As Byte
Private m_ReverseIndex2(0 To 255, 0 To 1) As Byte
Private m_ReverseIndex3(0 To 255, 0 To 1) As Byte
Private m_ReverseIndex4(0 To 255) As Byte
' Encode a string to a string.
Public Function Encode(sInput As String) As String
Dim bTemp() As Byte
'Convert to a byte array then convert.
'This is faster the repetitive calls to asc() or chr$()
bTemp = StrConv(sInput, vbFromUnicode)
Encode = StrConv(EncodeArr(bTemp), vbUnicode)
End Function
'Decode a string to a string.
Public Function Decode(sInput As String) As String
Dim bTemp() As Byte
'Convert to a byte array then convert.
'This is faster the repetitive calls to asc() or chr$()
bTemp = StrConv(sInput, vbFromUnicode)
Decode = StrConv(DecodeArr(bTemp), vbUnicode)
End Function
Public Sub DecodeToFile(sInput As String, sOutputFile As String)
Dim bTemp() As Byte
Dim fh As Long
fh = FreeFile(0)
Open sOutputFile For Binary Access Write As fh
Put fh, , bTemp
Close fh
End Sub
Public Sub DecodeFile(sInputFile As String, sOutputFile As String)
Dim bTemp() As Byte
Dim fh As Long
fh = FreeFile(0)
Open sInputFile For Binary Access Read As fh
ReDim bTemp(0 To LOF(fh) - 1)
Get fh, , bTemp
Close fh
bTemp = DecodeArr(bTemp)
Open sOutputFile For Binary Access Write As fh
Put fh, , bTemp
Close fh
End Sub
Public Function EncodeFromFile(sFileName As String) As String
Dim bTemp() As Byte
Dim fh As Long
fh = FreeFile(0)
Open sFileName For Binary Access Read As fh
ReDim bTemp(0 To LOF(fh) - 1)
Get fh, , bTemp
Close fh
EncodeFromFile = StrConv(EncodeArr(bTemp), vbUnicode)
End Function
Public Sub EncodeFile(sInputFile As String, sOutputFile As String)
Dim bTemp() As Byte
Dim fh As Long
fh = FreeFile(0)
Open sInputFile For Binary Access Read As fh
ReDim bTemp(0 To LOF(fh) - 1)
Get fh, , bTemp
Close fh
bTemp = EncodeArr(bTemp)
Open sOutputFile For Binary Access Write As fh
Put fh, , bTemp
Close fh
End Sub
Private Function EncodeArr(bInput() As Byte) As Byte()
Dim bOutput() As Byte
Dim k As Long
Dim l As Long
Dim i As Long
Dim evenBound As Long
Dim CurrentOut As Long
Dim b As Byte
Dim c As Byte
Dim d As Byte
Dim linelength As Long
k = LBound(bInput)
l = UBound(bInput)
'Calculate the input size
i = l - k + 1
'Calculate the output size
Select Case i Mod 3
Case 0:
i = (i \ 3) * 4
evenBound = l
Case 1:
i = ((i \ 3) * 4) + 4
evenBound = l - 1
Case 2:
i = ((i \ 3) * 4) + 4
evenBound = l - 2
Case 3:
i = ((i \ 3) * 4) + 4
evenBound = l - 3
End Select
'Add in the line feeds.
If i Mod MAX_LINELENGTH = 0 Then
i = i + (i \ MAX_LINELENGTH) * 2 - 2
Else
i = i + (i \ MAX_LINELENGTH) * 2
End If
'Size the output array
ReDim bOutput(0 To i - 1)
CurrentOut = 0
linelength = 0
For i = k To evenBound Step 3
b = bInput(i)
c = bInput(i + 1)
d = bInput(i + 2)
bOutput(CurrentOut) = m_Index1(b And &HFC)
bOutput(CurrentOut + 1) = m_Index2((b And &H3) Or (c And &HF0))
bOutput(CurrentOut + 2) = m_Index3((c And &HF) Or (d And &HC0))
bOutput(CurrentOut + 3) = m_Index4(d And &H3F)
CurrentOut = CurrentOut + 4
linelength = linelength + 4
If linelength >= MAX_LINELENGTH Then
If i <> l - 2 Then ' If this is the last line, don't add crlf
bOutput(CurrentOut) = CHAR_CR
bOutput(CurrentOut + 1) = CHAR_LF
End If
CurrentOut = CurrentOut + 2
linelength = 0
End If
Next i
Select Case l - i
Case 1:
b = bInput(i)
c = bInput(i + 1)
d = 0
bOutput(CurrentOut) = m_Index1(b And &HFC)
bOutput(CurrentOut + 1) = m_Index2((b And &H3) Or (c And &HF0))
bOutput(CurrentOut + 2) = m_Index3((c And &HF) Or (d And &HC0))
bOutput(CurrentOut + 3) = CHAR_EQUAL
CurrentOut = CurrentOut + 4
linelength = linelength + 4
Case 0:
b = bInput(i)
c = 0
bOutput(CurrentOut) = m_Index1(b And &HFC)
bOutput(CurrentOut + 1) = m_Index2((b And &H3) Or (c And &HF0))
bOutput(CurrentOut + 2) = CHAR_EQUAL
bOutput(CurrentOut + 3) = CHAR_EQUAL
CurrentOut = CurrentOut + 4
linelength = linelength + 4
End Select
EncodeArr = bOutput
End Function
Private Function DecodeArr(bInput() As Byte) As Byte()
Dim bOutput() As Byte
Dim OutLength As Long
Dim CurrentOut As Long
Dim k As Long
Dim l As Long
Dim i As Long
Dim j As Long
Dim b As Byte
Dim c As Byte
Dim d As Byte
Dim e As Byte
k = LBound(bInput)
l = UBound(bInput)
'Calculate the length of the input
i = l - k + 1
'Calculate the expected length of the output
'It should be no more (but may possible be less)
j = i Mod (MAX_LINELENGTH + 2)
If j = 0 Then
OutLength = (i \ (MAX_LINELENGTH + 2)) * (MAX_LINELENGTH \ 4) * 3
Else
j = (j / 4) * 3
If bInput(l) = CHAR_EQUAL Then j = j - 1
If bInput(l - 1) = CHAR_EQUAL Then j = j - 1
OutLength = (i \ (MAX_LINELENGTH + 2)) * (MAX_LINELENGTH \ 4) * 3 + j
End If
'Allocate the output
ReDim bOutput(0 To OutLength - 1)
CurrentOut = 0
For i = k To l
Select Case bInput(i)
Case CHAR_CR
'Do nothing
Case CHAR_LF
'Do nothing
Case Else
If l - i >= 3 Then
b = bInput(i)
c = bInput(i + 1)
d = bInput(i + 2)
e = bInput(i + 3)
If e <> CHAR_EQUAL Then
bOutput(CurrentOut) = m_ReverseIndex1(b) Or m_ReverseIndex2(c, 0)
bOutput(CurrentOut + 1) = m_ReverseIndex2(c, 1) Or m_ReverseIndex3(d, 0)
bOutput(CurrentOut + 2) = m_ReverseIndex3(d, 1) Or m_ReverseIndex4(e)
CurrentOut = CurrentOut + 3
i = i + 3
ElseIf d <> CHAR_EQUAL Then
bOutput(CurrentOut) = m_ReverseIndex1(b) Or m_ReverseIndex2(c, 0)
bOutput(CurrentOut + 1) = m_ReverseIndex2(c, 1) Or m_ReverseIndex3(d, 0)
CurrentOut = CurrentOut + 2
i = i + 3
Else
bOutput(CurrentOut) = m_ReverseIndex1(b) Or m_ReverseIndex2(c, 0)
CurrentOut = CurrentOut + 1
i = i + 3
End If
Else
'Possible input code error, but may also be
'an extra CrLf, so we will ignore it.
End If
End Select
Next i
'On properly formed input we should have to do this.
If OutLength <> CurrentOut + 1 Then
ReDim Preserve bOutput(0 To CurrentOut - 1)
End If
'Calculate the other Arrays
For i = 0 To 63
m_Index1((i * 4) And &HFC) = m_Index4(i)
m_Index2(((i And &HF) * 16) Or ((i And &H30) \ 16)) = m_Index4(i)
m_Index3((i \ 4 And &HF) Or ((i And &H3) * 64)) = m_Index4(i)
Next i
