虽然现在MD5 加密算法严格来讲已经不算安全,但一般小功能或公司内部使用应该足够了
Attribute VB_Name = "modMd5"
' MODULE: CMD5 '******************************************************************************* Option Explicit
Public Const BITS_TO_A_BYTE As Long = 8 Public Const BYTES_TO_A_WORD As Long = 4 Public Const BITS_TO_A_WORD As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE
Public m_lOnBits(0 To 30) As Long Public m_l2Power(0 To 30) As Long
Public Function MD5_Encrypt(ByVal sText As String) As String MD5_Init MD5_Encrypt = MD5(sText)
End Function
'******************************************************************************* ' Class_Initialize (SUB) ' ' DESCRIPTION: ' We will usually get quicker results by preparing arrays of bit patterns and ' powers of 2 ahead of time instead of calculating them every time,unless of ' course the methods are only ever getting called once per instantiation of the ' class. '******************************************************************************* Public Sub MD5_Init() ' Could have done this with a loop calculating each value,but simply ' assigning the values is quicker - BITS SET FROM RIGHT m_lOnBits(0) = 1 ' 00000000000000000000000000000001 m_lOnBits(1) = 3 ' 00000000000000000000000000000011 m_lOnBits(2) = 7 ' 00000000000000000000000000000111 m_lOnBits(3) = 15 ' 00000000000000000000000000001111 m_lOnBits(4) = 31 ' 00000000000000000000000000022222 m_lOnBits(5) = 63 ' 00000000000000000000000000222221 m_lOnBits(6) = 127 ' 00000000000000000000000002222211 m_lOnBits(7) = 255 ' 00000000000000000000000022222111 m_lOnBits(8) = 511 ' 00000000000000000000000222221111 m_lOnBits(9) = 1023 ' 00000000000000000000002222222222 m_lOnBits(10) = 2047 ' 00000000000000000000022222222221 m_lOnBits(11) = 4095 ' 00000000000000000000222222222211 m_lOnBits(12) = 8191 ' 00000000000000000002222222222111 m_lOnBits(13) = 16383 ' 00000000000000000022222222221111 m_lOnBits(14) = 32767 ' 00000000000000000222222222222222 m_lOnBits(15) = 65535 ' 00000000000000002222222222222221 m_lOnBits(16) = 131071 ' 00000000000000022222222222222211 m_lOnBits(17) = 262143 ' 00000000000000222222222222222111 m_lOnBits(18) = 524287 ' 00000000000002222222222222221111 m_lOnBits(19) = 1048575 ' 00000000000022222222222222222222 m_lOnBits(20) = 2097151 ' 00000000000222222222222222222221 m_lOnBits(21) = 4194303 ' 00000000002222222222222222222211 m_lOnBits(22) = 8388607 ' 00000000022222222222222222222111 m_lOnBits(23) = 16777215 ' 00000000222222222222222222221111 m_lOnBits(24) = 33554431 ' 00000002222222222222222222222222 m_lOnBits(25) = 67108863 ' 00000022222222222222222222222221 m_lOnBits(26) = 134217727 ' 00000222222222222222222222222211 m_lOnBits(27) = 268435455 ' 00002222222222222222222222222111 m_lOnBits(28) = 536870911 ' 00022222222222222222222222221111 m_lOnBits(29) = 1073741823 ' 00222222222222222222222222222222 m_lOnBits(30) = 2147483647 ' 02222222222222222222222222222221 ' Could have done this with a loop calculating each value,but simply ' assigning the values is quicker - POWERS OF 2 m_l2Power(0) = 1 ' 00000000000000000000000000000001 m_l2Power(1) = 2 ' 00000000000000000000000000000010 m_l2Power(2) = 4 ' 00000000000000000000000000000100 m_l2Power(3) = 8 ' 00000000000000000000000000001000 m_l2Power(4) = 16 ' 00000000000000000000000000010000 m_l2Power(5) = 32 ' 00000000000000000000000000100000 m_l2Power(6) = 64 ' 00000000000000000000000001000000 m_l2Power(7) = 128 ' 00000000000000000000000010000000 m_l2Power(8) = 256 ' 00000000000000000000000100000000 m_l2Power(9) = 512 ' 00000000000000000000001000000000 m_l2Power(10) = 1024 ' 00000000000000000000010000000000 m_l2Power(11) = 2048 ' 00000000000000000000100000000000 m_l2Power(12) = 4096 ' 00000000000000000001000000000000 m_l2Power(13) = 8192 ' 00000000000000000010000000000000 m_l2Power(14) = 16384 ' 00000000000000000100000000000000 m_l2Power(15) = 32768 ' 00000000000000001000000000000000 m_l2Power(16) = 65536 ' 00000000000000010000000000000000 m_l2Power(17) = 131072 ' 00000000000000100000000000000000 m_l2Power(18) = 262144 ' 00000000000001000000000000000000 m_l2Power(19) = 524288 ' 00000000000010000000000000000000 m_l2Power(20) = 1048576 ' 00000000000100000000000000000000 m_l2Power(21) = 2097152 ' 00000000001000000000000000000000 m_l2Power(22) = 4194304 ' 00000000010000000000000000000000 m_l2Power(23) = 8388608 ' 00000000100000000000000000000000 m_l2Power(24) = 16777216 ' 00000001000000000000000000000000 m_l2Power(25) = 33554432 ' 00000010000000000000000000000000 m_l2Power(26) = 67108864 ' 00000100000000000000000000000000 m_l2Power(27) = 134217728 ' 00001000000000000000000000000000 m_l2Power(28) = 268435456 ' 00010000000000000000000000000000 m_l2Power(29) = 536870912 ' 00100000000000000000000000000000 m_l2Power(30) = 1073741824 ' 01000000000000000000000000000000 End Sub
'******************************************************************************* ' LShift (FUNCTION) ' ' PARAMETERS: ' (In) - lValue - Long - The value to be shifted ' (In) - iShiftBits - Integer - The number of bits to shift the value by ' ' RETURN VALUE: ' Long - The shifted long integer ' ' DESCRIPTION: ' A left shift takes all the set binary bits and moves them left,in-filling ' with zeros in the vacated bits on the right. This function is equivalent to ' the << operator in Java and C++ '******************************************************************************* Private Function LShift(ByVal lValue As Long,_ ByVal iShiftBits As Integer) As Long ' NOTE: If you can guarantee that the Shift parameter will be in the ' range 1 to 30 you can safely strip of this first nested if structure for ' speed. ' ' A shift of zero is no shift at all. If iShiftBits = 0 Then LShift = lValue Exit Function ' A shift of 31 will result in the right most bit becoming the left most ' bit and all other bits being cleared ElseIf iShiftBits = 31 Then If lValue And 1 Then LShift = &H80000000 Else LShift = 0 End If Exit Function ' A shift of less than zero or more than 31 is undefined ElseIf iShiftBits < 0 Or iShiftBits > 31 Then Err.Raise 6 End If ' If the left most bit that remains will end up in the negative bit ' position (&H80000000) we would end up with an overflow if we took the ' standard route. We need to strip the left most bit and add it back ' afterwards. If (lValue And m_l2Power(31 - iShiftBits)) Then ' (Value And OnBits(31 - (Shift + 1))) chops off the left most bits that ' we are shifting into,but also the left most bit we still want as this ' is going to end up in the negative bit marker position (&H80000000). ' After the multiplication/shift we Or the result with &H80000000 to ' turn the negative bit on. LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * _ m_l2Power(iShiftBits)) Or &H80000000 Else ' (Value And OnBits(31-Shift)) chops off the left most bits that we are ' shifting into so we do not get an overflow error when we do the ' multiplication/shift LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * _ m_l2Power(iShiftBits)) End If End Function
'******************************************************************************* ' RShift (FUNCTION) ' ' PARAMETERS: ' (In) - lValue - Long - The value to be shifted ' (In) - iShiftBits - Integer - The number of bits to shift the value by ' ' RETURN VALUE: ' Long - The shifted long integer ' ' DESCRIPTION: ' The right shift of an unsigned long integer involves shifting all the set bits ' to the right and in-filling on the left with zeros. This function is ' equivalent to the >>> operator in Java or the >> operator in C++ when used on ' an unsigned long. '******************************************************************************* Private Function RShift(ByVal lValue As Long,_ ByVal iShiftBits As Integer) As Long ' NOTE: If you can guarantee that the Shift parameter will be in the ' range 1 to 30 you can safely strip of this first nested if structure for ' speed. ' ' A shift of zero is no shift at all If iShiftBits = 0 Then RShift = lValue Exit Function ' A shift of 31 will clear all bits and move the left most bit to the right ' most bit position ElseIf iShiftBits = 31 Then If lValue And &H80000000 Then RShift = 1 Else RShift = 0 End If Exit Function ' A shift of less than zero or more than 31 is undefined ElseIf iShiftBits < 0 Or iShiftBits > 31 Then Err.Raise 6 End If ' We do not care about the top most bit or the final bit,the top most bit ' will be taken into account in the next stage,the final bit (whether it ' is an odd number or not) is being shifted into,so we do not give a jot ' about it RShift = (lValue And &H7FFFFFFE) / m_l2Power(iShiftBits) ' If the top most bit (&H80000000) was set we need to do things differently ' as in a normal VB signed long integer the top most bit is used to indicate ' the sign of the number,when it is set it is a negative number,so just ' deviding by a factor of 2 as above would not work. ' NOTE: (lValue And &H80000000) is equivalent to (lValue < 0),you could ' get a very marginal speed improvement by changing the test to (lValue < 0) If (lValue And &H80000000) Then ' We take the value computed so far,and then add the left most negative ' bit after it has been shifted to the right the appropriate number of ' places RShift = (RShift Or (&H40000000 / m_l2Power(iShiftBits - 1))) End If End Function
'******************************************************************************* ' RShiftSigned (FUNCTION) ' ' PARAMETERS: ' (In) - lValue - Long - ' (In) - iShiftBits - Integer - ' ' RETURN VALUE: ' Long - ' ' DESCRIPTION: ' The right shift of a signed long integer involves shifting all the set bits to ' the right and in-filling on the left with the sign bit (0 if positive,1 if ' negative. This function is equivalent to the >> operator in Java or the >> ' operator in C++ when used on a signed long integer. Not used in this class, ' but included for completeness. '******************************************************************************* Private Function RShiftSigned(ByVal lValue As Long,_ ByVal iShiftBits As Integer) As Long ' NOTE: If you can guarantee that the Shift parameter will be in the ' range 1 to 30 you can safely strip of this first nested if structure for ' speed. ' ' A shift of zero is no shift at all If iShiftBits = 0 Then RShiftSigned = lValue Exit Function ' A shift of 31 will clear all bits if the left most bit was zero,and will ' set all bits if the left most bit was 1 (a negative indicator) ElseIf iShiftBits = 31 Then ' NOTE: (lValue And &H80000000) is equivalent to (lValue < 0),you ' could get a very marginal speed improvement by changing the test to ' (lValue < 0) If (lValue And &H80000000) Then RShiftSigned = -1 Else RShiftSigned = 0 End If Exit Function ' A shift of less than zero or more than 31 is undefined ElseIf iShiftBits < 0 Or iShiftBits > 31 Then Err.Raise 6 End If ' We get the same result by dividing by the appropriate power of 2 and ' rounding in the negative direction RShiftSigned = Int(lValue / m_l2Power(iShiftBits)) End Function
'******************************************************************************* ' RotateLeft (FUNCTION) ' ' PARAMETERS: ' (In) - lValue - Long - Value to act on ' (In) - iShiftBits - Integer - Bits to move by ' ' RETURN VALUE: ' Long - Result ' ' DESCRIPTION: ' Rotates the bits in a long integer to the left,those bits falling off the ' left edge are put back on the right edge '******************************************************************************* Private Function RotateLeft(ByVal lValue As Long,_ ByVal iShiftBits As Integer) As Long RotateLeft = LShift(lValue,iShiftBits) Or RShift(lValue,(32 - iShiftBits)) End Function
'******************************************************************************* ' AddUnsigned (FUNCTION) ' ' PARAMETERS: ' (In) - lX - Long - First value ' (In) - lY - Long - Second value ' ' RETURN VALUE: ' Long - Result ' ' DESCRIPTION: ' Adds two potentially large unsigned numbers without overflowing '******************************************************************************* Private Function AddUnsigned(ByVal lX As Long,_ ByVal lY As Long) As Long Dim lX4 As Long Dim lY4 As Long Dim lX8 As Long Dim lY8 As Long Dim lResult As Long
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
'******************************************************************************* ' F (FUNCTION) ' ' DESCRIPTION: ' MD5's F function '******************************************************************************* Private Function F(ByVal x As Long,_ ByVal y As Long,_ ByVal z As Long) As Long F = (x And y) Or ((Not x) And z) End Function
'******************************************************************************* ' G (FUNCTION) ' ' DESCRIPTION: ' MD5's G function '******************************************************************************* Private Function G(ByVal x As Long,_ ByVal z As Long) As Long G = (x And z) Or (y And (Not z)) End Function
'******************************************************************************* ' H (FUNCTION) ' ' DESCRIPTION: ' MD5's H function '******************************************************************************* Private Function H(ByVal x As Long,_ ByVal z As Long) As Long H = (x Xor y Xor z) End Function
'******************************************************************************* ' I (FUNCTION) ' ' DESCRIPTION: ' MD5's I function '******************************************************************************* Private Function i(ByVal x As Long,_ ByVal z As Long) As Long i = (y Xor (x Or (Not z))) End Function
'******************************************************************************* ' FF (SUB) ' ' DESCRIPTION: ' MD5's FF procedure '******************************************************************************* Private Sub FF(a As Long,_ ByVal b As Long,_ ByVal c As Long,_ ByVal d As Long,_ ByVal x As Long,_ ByVal s As Long,_ ByVal ac As Long) a = AddUnsigned(a,AddUnsigned(AddUnsigned(F(b,c,d),x),ac)) a = RotateLeft(a,s) a = AddUnsigned(a,b) End Sub
'******************************************************************************* ' GG (SUB) ' ' DESCRIPTION: ' MD5's GG procedure '******************************************************************************* Private Sub GG(a As Long,AddUnsigned(AddUnsigned(G(b,b) End Sub
'******************************************************************************* ' HH (SUB) ' ' DESCRIPTION: ' MD5's HH procedure '******************************************************************************* Private Sub HH(a As Long,AddUnsigned(AddUnsigned(H(b,b) End Sub
'******************************************************************************* ' II (SUB) ' ' DESCRIPTION: ' MD5's II procedure '******************************************************************************* Private Sub II(a As Long,AddUnsigned(AddUnsigned(i(b,b) End Sub
'******************************************************************************* ' ConvertToWordArray (FUNCTION) ' ' PARAMETERS: ' (In/Out) - sMessage - String - String message ' ' RETURN VALUE: ' Long() - Converted message as long array ' ' DESCRIPTION: ' Takes the string message and puts it in a long array with padding according to ' the MD5 rules. Note we are using only the first byte of each character with ' the AscB function,this may well mess up in unicode/dbcs situations where you ' are comparing what was generated on two different PCs with different ' character sets. '******************************************************************************* Private Function ConvertToWordArray(sMessage As String) As Long() Dim lMessageLength As Long Dim lNumberOfWords As Long Dim lWordArray() As Long Dim lBytePosition As Long Dim lByteCount As Long Dim lWordCount As Long Dim lChar As Long Const MODULUS_BITS As Long = 512 Const CONGRUENT_BITS As Long = 448 lMessageLength = Len(sMessage) ' Get padded number of words. Message needs to be congruent to 448 bits, ' modulo 512 bits. If it is exactly congruent to 448 bits,modulo 512 bits ' it must still have another 512 bits added. 512 bits = 64 bytes ' (or 16 * 4 byte words),448 bits = 56 bytes. This means lMessageSize must ' be a multiple of 16 (i.e. 16 * 4 (bytes) * 8 (bits)) lNumberOfWords = (((lMessageLength + _ ((MODULUS_BITS - CONGRUENT_BITS) / BITS_TO_A_BYTE)) / _ (MODULUS_BITS / BITS_TO_A_BYTE)) + 1) * _ (MODULUS_BITS / BITS_TO_A_WORD) ReDim lWordArray(lNumberOfWords - 1) ' Combine each block of 4 bytes (ascii code of character) into one long ' value and store in the message. The high-order (most significant) bit of ' each byte is listed first. However,the low-order (least significant) byte ' is given first in each word. lBytePosition = 0 lByteCount = 0 Do Until lByteCount >= lMessageLength ' Each word is 4 bytes lWordCount = lByteCount / BYTES_TO_A_WORD ' The bytes are put in the word from the right most edge lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE lChar = AscB(Mid(sMessage,lByteCount + 1,1)) lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(lChar,lBytePosition) lByteCount = lByteCount + 1 Loop
' Terminate according to MD5 rules with a 1 bit,zeros and the length in ' bits stored in the last two words lWordCount = lByteCount / BYTES_TO_A_WORD lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
' Add a terminating 1 bit,all the rest of the bits to the end of the ' word array will default to zero lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80,lBytePosition)
' We put the length of the message in bits into the last two words,to get ' the length in bits we need to multiply by 8 (or left shift 3). This left ' shifted value is put in the first word. Any bits shifted off the left edge ' need to be put in the second word,we can work out which bits by shifting ' right the length by 29 bits. lWordArray(lNumberOfWords - 2) = LShift(lMessageLength,3) lWordArray(lNumberOfWords - 1) = RShift(lMessageLength,29) ConvertToWordArray = lWordArray End Function
'******************************************************************************* ' WordToHex (FUNCTION) ' ' PARAMETERS: ' (In) - lValue - Long - Long value to convert ' ' RETURN VALUE: ' String - Hex value to return ' ' DESCRIPTION: ' Takes a long integer and due to the bytes reverse order it extracts the ' individual bytes and converts them to hex appending them for an overall hex ' value '******************************************************************************* Private Function WordToHex(ByVal lValue As Long) As String Dim lByte As Long Dim lCount As Long 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
'******************************************************************************* ' MD5 (FUNCTION) ' ' PARAMETERS: ' (In/Out) - sMessage - String - String to be digested ' ' RETURN VALUE: ' String - The MD5 digest ' ' DESCRIPTION: ' This function takes a string message and generates an MD5 digest for it. ' sMessage can be up to the VB string length limit of 2^31 (approx. 2 billion) ' characters. ' ' NOTE: Due to the way in which the string is processed the routine assumes a ' single byte character set. VB passes unicode (2-byte) character strings,the ' ConvertToWordArray function uses on the first byte for each character. This ' has been done this way for ease of use,to make the routine truely portable ' you could accept a byte array instead,it would then be up to the calling ' routine to make sure that the byte array is generated from their string in ' a manner consistent with the string type. '******************************************************************************* Public Function MD5(sMessage As String) As String Dim x() As Long Dim k As Long Dim AA As Long Dim BB As Long Dim CC As Long Dim DD As Long Dim a As Long Dim b As Long Dim c As Long Dim d As Long Const S11 As Long = 7 Const S12 As Long = 12 Const S13 As Long = 17 Const S14 As Long = 22 Const S21 As Long = 5 Const S22 As Long = 9 Const S23 As Long = 14 Const S24 As Long = 20 Const S31 As Long = 4 Const S32 As Long = 11 Const S33 As Long = 16 Const S34 As Long = 23 Const S41 As Long = 6 Const S42 As Long = 10 Const S43 As Long = 15 Const S44 As Long = 21
' Steps 1 and 2. Append padding bits and length and convert to words x = ConvertToWordArray(sMessage) ' Step 3. Initialise a = &H67452301 b = &HEFCDAB89 c = &H98BADCFE d = &H10325476
' Step 4. Process the message in 16-word blocks For k = 0 To UBound(x) Step 16 AA = a BB = b CC = c DD = d ' The hex number on the end of each of the following procedure calls is ' an element from the 64 element table constructed with ' T(i) = Int(4294967296 * Abs(Sin(i))) where i is 1 to 64. ' ' However,for speed we don't want to calculate the value every time. FF a,b,d,x(k + 0),S11,&HD76AA478 FF d,a,x(k + 1),S12,&HE8C7B756 FF c,x(k + 2),S13,&H242070DB FF b,x(k + 3),S14,&HC1BDCEEE FF a,x(k + 4),&HF57C0FAF FF d,x(k + 5),&H4787C62A FF c,x(k + 6),&HA8304613 FF b,x(k + 7),&HFD469501 FF a,x(k + 8),&H698098D8 FF d,x(k + 9),&H8B44F7AF FF c,x(k + 10),&HFFFF5BB1 FF b,x(k + 11),&H895CD7BE FF a,x(k + 12),&H6B901122 FF d,x(k + 13),&HFD987193 FF c,x(k + 14),&HA679438E FF b,x(k + 15),&H49B40821 GG a,S21,&HF61E2562 GG d,S22,&HC040B340 GG c,S23,&H265E5A51 GG b,S24,&HE9B6C7AA GG a,&HD62F105D GG d,&H2441453 GG c,&HD8A1E681 GG b,&HE7D3FBC8 GG a,&H21E1CDE6 GG d,&HC33707D6 GG c,&HF4D50D87 GG b,&H455A14ED GG a,&HA9E3E905 GG d,&HFCEFA3F8 GG c,&H676F02D9 GG b,&H8D2A4C8A HH a,S31,&HFFFA3942 HH d,S32,&H8771F681 HH c,S33,&H6D9D6122 HH b,S34,&HFDE5380C HH a,&HA4BEEA44 HH d,&H4BDECFA9 HH c,&HF6BB4B60 HH b,&HBEBFBC70 HH a,&H289B7EC6 HH d,&HEAA127FA HH c,&HD4EF3085 HH b,&H4881D05 HH a,&HD9D4D039 HH d,&HE6DB99E5 HH c,&H1FA27CF8 HH b,&HC4AC5665 II a,S41,&HF4292244 II d,S42,&H432AFF97 II c,S43,&HAB9423A7 II b,S44,&HFC93A039 II a,&H655B59C3 II d,&H8F0CCC92 II c,&HFFEFF47D II b,&H85845DD1 II a,&H6FA87E4F II d,&HFE2CE6E0 II c,&HA3014314 II b,&H4E0811A1 II a,&HF7537E82 II d,&HBD3AF235 II c,&H2AD7D2BB II b,&HEB86D391 a = AddUnsigned(a,AA) b = AddUnsigned(b,BB) c = AddUnsigned(c,CC) d = AddUnsigned(d,DD) Next ' Step 5. Output the 128 bit digest '=LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d)) MD5 = LCase(WordToHex(b) & WordToHex(c)) End Function
Public Function Encrypt(ByVal sText As String,Optional ByVal bNewEncrypt As Boolean = False) As String If bNewEncrypt = False Then Dim m_objEncrypt As Object Set m_objEncrypt = CreateObject("StrongEncrypt.Encrypt") Encrypt = m_objEncrypt.Encrypt(sText) Set m_objEncrypt = Nothing Else Encrypt = MD5_Encrypt(sText) End If
End Function (编辑:李大同)
【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容!
|