VB下的MD5编码类模块
Option Explicit
‘==================================================
‘作 用：设置类模块变量,1.FileMD5 path ,文件md5,2.StringMD5,字符串md5
‘==================================================
Private Const BITS_TO_A_BYTE As Long = 8
Private Const BYTES_TO_A_WORD As Long = 4
Private Const BITS_TO_A_WORD As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE
Private m_lOnBits(0 To 30) As Long
Private m_l2Power(0 To 30) As Long
‘==================================================
‘作 用：返回事件
‘==================================================
Event Err()
‘==================================================
‘作 用：初始化
‘==================================================
Private Sub Class_Initialize()
m_lOnBits(0) = 1
m_lOnBits(1) = 3
m_lOnBits(2) = 7
m_lOnBits(3) = 15
m_lOnBits(4) = 31
m_lOnBits(5) = 63
m_lOnBits(6) = 127
m_lOnBits(7) = 255
m_lOnBits(8) = 511
m_lOnBits(9) = 1023
m_lOnBits(10) = 2047
m_lOnBits(11) = 4095
m_lOnBits(12) = 8191
m_lOnBits(13) = 16383
m_lOnBits(14) = 32767
m_lOnBits(15) = 65535
m_lOnBits(16) = 131071
m_lOnBits(17) = 262143
m_lOnBits(18) = 524287
m_lOnBits(19) = 1048575
m_lOnBits(20) = 2097151
m_lOnBits(21) = 4194303
m_lOnBits(22) = 8388607
m_lOnBits(23) = 16777215
m_lOnBits(24) = 33554431
m_lOnBits(25) = 67108863
m_lOnBits(26) = 134217727
m_lOnBits(27) = 268435455
m_lOnBits(28) = 536870911
m_lOnBits(29) = 1073741823
m_lOnBits(30) = 2147483647
m_l2Power(0) = 1
m_l2Power(1) = 2
m_l2Power(2) = 4
m_l2Power(3) = 8
m_l2Power(4) = 16
m_l2Power(5) = 32
m_l2Power(6) = 64
m_l2Power(7) = 128
m_l2Power(8) = 256
m_l2Power(9) = 512
m_l2Power(10) = 1024
m_l2Power(11) = 2048
m_l2Power(12) = 4096
m_l2Power(13) = 8192
m_l2Power(14) = 16384
m_l2Power(15) = 32768
m_l2Power(16) = 65536
m_l2Power(17) = 131072
m_l2Power(18) = 262144
m_l2Power(19) = 524288
m_l2Power(20) = 1048576
m_l2Power(21) = 2097152
m_l2Power(22) = 4194304
m_l2Power(23) = 8388608
m_l2Power(24) = 16777216
m_l2Power(25) = 33554432
m_l2Power(26) = 67108864
m_l2Power(27) = 134217728
m_l2Power(28) = 268435456
m_l2Power(29) = 536870912
m_l2Power(30) = 1073741824
End Sub
Private Function LShift(ByVal lValue As Long, ByVal iShiftBits As Integer) As Long
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(ByVal lValue As Long, ByVal iShiftBits As Integer) As Long
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 RShiftSigned(ByVal lValue As Long, ByVal iShiftBits As Integer) As Long
If iShiftBits = 0 Then
RShiftSigned = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If (lValue And &H80000000) Then
RShiftSigned = -1
Else
RShiftSigned = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
RShiftSigned = Int(lValue / m_l2Power(iShiftBits))
End Function
Private Function RotateLeft(ByVal lValue As Long, ByVal iShiftBits As Integer) As Long
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 – iShiftBits))
End Function
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
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
Private Function G(ByVal x As Long, ByVal y As Long, ByVal z As Long) As Long
G = (x And z) Or (y And (Not z))
End Function
Private Function H(ByVal x As Long, ByVal y As Long, ByVal z As Long) As Long
H = (x Xor y Xor z)
End Function
Private Function i(ByVal x As Long, ByVal y As Long, ByVal z As Long) As Long
i = (y Xor (x Or (Not z)))
End Function
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
Private Sub GG(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(G(B, C, D), x), ac))
A = RotateLeft(A, S)
A = AddUnsigned(A, B)
End Sub
Private Sub HH(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(H(B, C, D), x), ac))
A = RotateLeft(A, S)
A = AddUnsigned(A, B)
End Sub
Private Sub II(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(i(B, C, D), x), ac))
A = RotateLeft(A, S)
A = AddUnsigned(A, B)
End Sub
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
Const MODULUS_BITS As Long = 512
Const CONGRUENT_BITS As Long = 448
sMessage = StrConv(sMessage, vbFromUnicode)
lMessageLength = LenB(sMessage)
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)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or _
LShift(AscB(MidB(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords – 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords – 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Private Function ConvertByteArrayToWordArray(bytMessage() As Byte) 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
Const MODULUS_BITS As Long = 512
Const CONGRUENT_BITS As Long = 448
lMessageLength = UBound(bytMessage) + 1
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)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(bytMessage(lByteCount), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords – 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords – 1) = RShift(lMessageLength, 29)
ConvertByteArrayToWordArray = lWordArray
End Function
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
‘==================================================
Public Function StringMD5(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
x = ConvertToWordArray(sMessage)
A = &H67452301
B = &HEFCDAB89
C = &H98BADCFE
D = &H10325476
For K = 0 To UBound(x) Step 16
AA = A
BB = B
CC = C
DD = D
FF A, B, C, D, x(K + 0), S11, &HD76AA478
FF D, A, B, C, x(K + 1), S12, &HE8C7B756
FF C, D, A, B, x(K + 2), S13, &H242070DB
FF B, C, D, A, x(K + 3), S14, &HC1BDCEEE
FF A, B, C, D, x(K + 4), S11, &HF57C0FAF
FF D, A, B, C, x(K + 5), S12, &H4787C62A
FF C, D, A, B, x(K + 6), S13, &HA8304613
FF B, C, D, A, x(K + 7), S14, &HFD469501
FF A, B, C, D, x(K + 8), S11, &H698098D8
FF D, A, B, C, x(K + 9), S12, &H8B44F7AF
FF C, D, A, B, x(K + 10), S13, &HFFFF5BB1
FF B, C, D, A, x(K + 11), S14, &H895CD7BE
FF A, B, C, D, x(K + 12), S11, &H6B901122
FF D, A, B, C, x(K + 13), S12, &HFD987193
FF C, D, A, B, x(K + 14), S13, &HA679438E
FF B, C, D, A, x(K + 15), S14, &H49B40821
GG A, B, C, D, x(K + 1), S21, &HF61E2562
GG D, A, B, C, x(K + 6), S22, &HC040B340
GG C, D, A, B, x(K + 11), S23, &H265E5A51
GG B, C, D, A, x(K + 0), S24, &HE9B6C7AA
GG A, B, C, D, x(K + 5), S21, &HD62F105D
GG D, A, B, C, x(K + 10), S22, &H2441453
GG C, D, A, B, x(K + 15), S23, &HD8A1E681
GG B, C, D, A, x(K + 4), S24, &HE7D3FBC8
GG A, B, C, D, x(K + 9), S21, &H21E1CDE6
GG D, A, B, C, x(K + 14), S22, &HC33707D6
GG C, D, A, B, x(K + 3), S23, &HF4D50D87
GG B, C, D, A, x(K + 8), S24, &H455A14ED
GG A, B, C, D, x(K + 13), S21, &HA9E3E905
GG D, A, B, C, x(K + 2), S22, &HFCEFA3F8
GG C, D, A, B, x(K + 7), S23, &H676F02D9
GG B, C, D, A, x(K + 12), S24, &H8D2A4C8A
HH A, B, C, D, x(K + 5), S31, &HFFFA3942
HH D, A, B, C, x(K + 8), S32, &H8771F681
HH C, D, A, B, x(K + 11), S33, &H6D9D6122
HH B, C, D, A, x(K + 14), S34, &HFDE5380C
HH A, B, C, D, x(K + 1), S31, &HA4BEEA44
HH D, A, B, C, x(K + 4), S32, &H4BDECFA9
HH C, D, A, B, x(K + 7), S33, &HF6BB4B60
HH B, C, D, A, x(K + 10), S34, &HBEBFBC70
HH A, B, C, D, x(K + 13), S31, &H289B7EC6
HH D, A, B, C, x(K + 0), S32, &HEAA127FA
HH C, D, A, B, x(K + 3), S33, &HD4EF3085
HH B, C, D, A, x(K + 6), S34, &H4881D05
HH A, B, C, D, x(K + 9), S31, &HD9D4D039
HH D, A, B, C, x(K + 12), S32, &HE6DB99E5
HH C, D, A, B, x(K + 15), S33, &H1FA27CF8
HH B, C, D, A, x(K + 2), S34, &HC4AC5665
II A, B, C, D, x(K + 0), S41, &HF4292244
II D, A, B, C, x(K + 7), S42, &H432AFF97
II C, D, A, B, x(K + 14), S43, &HAB9423A7
II B, C, D, A, x(K + 5), S44, &HFC93A039
II A, B, C, D, x(K + 12), S41, &H655B59C3
II D, A, B, C, x(K + 3), S42, &H8F0CCC92
II C, D, A, B, x(K + 10), S43, &HFFEFF47D
II B, C, D, A, x(K + 1), S44, &H85845DD1
II A, B, C, D, x(K + 8), S41, &H6FA87E4F
II D, A, B, C, x(K + 15), S42, &HFE2CE6E0
II C, D, A, B, x(K + 6), S43, &HA3014314
II B, C, D, A, x(K + 13), S44, &H4E0811A1
II A, B, C, D, x(K + 4), S41, &HF7537E82
II D, A, B, C, x(K + 11), S42, &HBD3AF235
II C, D, A, B, x(K + 2), S43, &H2AD7D2BB
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
StringMD5 = LCase(WordToHex(A) & WordToHex(B) & WordToHex(C) & WordToHex(D))
End Function
‘==================================================
‘作 用：计算数组的md5
‘==================================================
Public Function MD5(bytMessage() As Byte) 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
x = ConvertByteArrayToWordArray(bytMessage)
A = &H67452301
B = &HEFCDAB89
C = &H98BADCFE
D = &H10325476
For K = 0 To UBound(x) Step 16
AA = A
BB = B
CC = C
DD = D
FF A, B, C, D, x(K + 0), S11, &HD76AA478
FF D, A, B, C, x(K + 1), S12, &HE8C7B756
FF C, D, A, B, x(K + 2), S13, &H242070DB
FF B, C, D, A, x(K + 3), S14, &HC1BDCEEE
FF A, B, C, D, x(K + 4), S11, &HF57C0FAF
FF D, A, B, C, x(K + 5), S12, &H4787C62A
FF C, D, A, B, x(K + 6), S13, &HA8304613
FF B, C, D, A, x(K + 7), S14, &HFD469501
FF A, B, C, D, x(K + 8), S11, &H698098D8
FF D, A, B, C, x(K + 9), S12, &H8B44F7AF
FF C, D, A, B, x(K + 10), S13, &HFFFF5BB1
FF B, C, D, A, x(K + 11), S14, &H895CD7BE
FF A, B, C, D, x(K + 12), S11, &H6B901122
FF D, A, B, C, x(K + 13), S12, &HFD987193
FF C, D, A, B, x(K + 14), S13, &HA679438E
FF B, C, D, A, x(K + 15), S14, &H49B40821
GG A, B, C, D, x(K + 1), S21, &HF61E2562
GG D, A, B, C, x(K + 6), S22, &HC040B340
GG C, D, A, B, x(K + 11), S23, &H265E5A51
GG B, C, D, A, x(K + 0), S24, &HE9B6C7AA
GG A, B, C, D, x(K + 5), S21, &HD62F105D
GG D, A, B, C, x(K + 10), S22, &H2441453
GG C, D, A, B, x(K + 15), S23, &HD8A1E681
GG B, C, D, A, x(K + 4), S24, &HE7D3FBC8
GG A, B, C, D, x(K + 9), S21, &H21E1CDE6
GG D, A, B, C, x(K + 14), S22, &HC33707D6
GG C, D, A, B, x(K + 3), S23, &HF4D50D87
GG B, C, D, A, x(K + 8), S24, &H455A14ED
GG A, B, C, D, x(K + 13), S21, &HA9E3E905
GG D, A, B, C, x(K + 2), S22, &HFCEFA3F8
GG C, D, A, B, x(K + 7), S23, &H676F02D9
GG B, C, D, A, x(K + 12), S24, &H8D2A4C8A
HH A, B, C, D, x(K + 5), S31, &HFFFA3942
HH D, A, B, C, x(K + 8), S32, &H8771F681
HH C, D, A, B, x(K + 11), S33, &H6D9D6122
HH B, C, D, A, x(K + 14), S34, &HFDE5380C
HH A, B, C, D, x(K + 1), S31, &HA4BEEA44
HH D, A, B, C, x(K + 4), S32, &H4BDECFA9
HH C, D, A, B, x(K + 7), S33, &HF6BB4B60
HH B, C, D, A, x(K + 10), S34, &HBEBFBC70
HH A, B, C, D, x(K + 13), S31, &H289B7EC6
HH D, A, B, C, x(K + 0), S32, &HEAA127FA
HH C, D, A, B, x(K + 3), S33, &HD4EF3085
HH B, C, D, A, x(K + 6), S34, &H4881D05
HH A, B, C, D, x(K + 9), S31, &HD9D4D039
HH D, A, B, C, x(K + 12), S32, &HE6DB99E5
HH C, D, A, B, x(K + 15), S33, &H1FA27CF8
HH B, C, D, A, x(K + 2), S34, &HC4AC5665
II A, B, C, D, x(K + 0), S41, &HF4292244
II D, A, B, C, x(K + 7), S42, &H432AFF97
II C, D, A, B, x(K + 14), S43, &HAB9423A7
II B, C, D, A, x(K + 5), S44, &HFC93A039
II A, B, C, D, x(K + 12), S41, &H655B59C3
II D, A, B, C, x(K + 3), S42, &H8F0CCC92
II C, D, A, B, x(K + 10), S43, &HFFEFF47D
II B, C, D, A, x(K + 1), S44, &H85845DD1
II A, B, C, D, x(K + 8), S41, &H6FA87E4F
II D, A, B, C, x(K + 15), S42, &HFE2CE6E0
II C, D, A, B, x(K + 6), S43, &HA3014314
II B, C, D, A, x(K + 13), S44, &H4E0811A1
II A, B, C, D, x(K + 4), S41, &HF7537E82
II D, A, B, C, x(K + 11), S42, &HBD3AF235
II C, D, A, B, x(K + 2), S43, &H2AD7D2BB
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))
End Function
‘==================================================
‘作 用：计算文件的md5，这个函数一次性读取文件到数组，故处理较大文件时效率较低
‘==================================================
Public Function FileMD5(strFilename As String) As String
Dim lngFileNo As Long
Dim bytData() As Byte
If Dir(strFilename, 7) = “” Then
GoTo PROC_EXIT
End If
lngFileNo = FreeFile
On Error GoTo PROC_ERR
Open strFilename For Binary As lngFileNo
ReDim bytData(LOF(lngFileNo) – 1) As Byte
Get #lngFileNo, 1, bytData
Close lngFileNo
FileMD5 = MD5(bytData)
PROC_EXIT:
Erase bytData
Exit Function
PROC_ERR:
Close
GoTo PROC_EXIT
End Function
