网上找的...

Option Explicit

Dim w1 As String, w2 As String, w3 As String, w4 As String

Function MD5F(ByVal tempstr As String, ByVal w As String, ByVal X As String, ByVal y As String, ByVal z As String, ByVal Xin As String, ByVal qdata As String, ByVal rots As Integer)
MD5F = BigMod32Add(RotLeft(BigMod32Add(BigMod32Add(w, tempstr), BigMod32Add(Xin, qdata)), rots), X)
End Function

Sub MD5F1(w As String, ByVal X As String, ByVal y As String, ByVal z As String, ByVal Xin As String, ByVal qdata As String, ByVal rots As Integer)
Dim tempstr As String

tempstr = BigXOR(z, BigAND(X, BigXOR(y, z)))
w = MD5F(tempstr, w, X, y, z, Xin, qdata, rots)
End Sub

Sub MD5F2(w As String, ByVal X As String, ByVal y As String, ByVal z As String, ByVal Xin As String, ByVal qdata As String, ByVal rots As Integer)
Dim tempstr As String

tempstr = BigXOR(y, BigAND(z, BigXOR(X, y)))
w = MD5F(tempstr, w, X, y, z, Xin, qdata, rots)
End Sub

Sub MD5F3(w As String, ByVal X As String, ByVal y As String, ByVal z As String, ByVal Xin As String, ByVal qdata As String, ByVal rots As Integer)
Dim tempstr As String

tempstr = BigXOR(X, BigXOR(y, z))
w = MD5F(tempstr, w, X, y, z, Xin, qdata, rots)
End Sub

Sub MD5F4(w As String, ByVal X As String, ByVal y As String, ByVal z As String, ByVal Xin As String, ByVal qdata As String, ByVal rots As Integer)
Dim tempstr As String

tempstr = BigXOR(y, BigOR(X, BigNOT(z)))
w = MD5F(tempstr, w, X, y, z, Xin, qdata, rots)
End Sub

Function MD5_Calc(ByVal hashthis As String) As String
ReDim buf(0 To 3) As String
ReDim Xin(0 To 15) As String
Dim tempnum As Integer, tempnum2 As Integer, loopit As Integer, loopouter As Integer, loopinner As Integer
Dim a As String, b As String, c As String, d As String

tempnum = 8 * Len(hashthis)
hashthis = hashthis + Chr$(128) 'Add binary 10000000
tempnum2 = 56 - Len(hashthis) Mod 64

If tempnum2 < 0 Then
tempnum2 = 64 + tempnum2
End If

hashthis = hashthis + String$(tempnum2, Chr$(0))

For loopit = 1 To 8
hashthis = hashthis + Chr$(tempnum Mod 256)
tempnum = tempnum - tempnum Mod 256
tempnum = tempnum / 256
Next loopit

buf(0) = "67452301"
buf(1) = "efcdab89"
buf(2) = "98badcfe"
buf(3) = "10325476"

For loopouter = 0 To Len(hashthis) / 64 - 1
a = buf(0)
b = buf(1)
c = buf(2)
d = buf(3)

' Get the 512 bits
For loopit = 0 To 15
Xin(loopit) = ""
For loopinner = 1 To 4
Xin(loopit) = Hex$(Asc(Mid$(hashthis, 64 * loopouter + 4 * loopit + loopinner, 1))) + Xin(loopit)
If Len(Xin(loopit)) Mod 2 Then Xin(loopit) = "0" + Xin(loopit)
Next loopinner
Next loopit

' 第一轮循环
MD5F1 a, b, c, d, Xin(0), "d76aa478", 7
MD5F1 d, a, b, c, Xin(1), "e8c7b756", 12
MD5F1 c, d, a, b, Xin(2), "242070db", 17
MD5F1 b, c, d, a, Xin(3), "c1bdceee", 22
MD5F1 a, b, c, d, Xin(4), "f57c0faf", 7
MD5F1 d, a, b, c, Xin(5), "4787c62a", 12
MD5F1 c, d, a, b, Xin(6), "a8304613", 17
MD5F1 b, c, d, a, Xin(7), "fd469501", 22
MD5F1 a, b, c, d, Xin(8), "698098d8", 7
MD5F1 d, a, b, c, Xin(9), "8b44f7af", 12
MD5F1 c, d, a, b, Xin(10), "ffff5bb1", 17
MD5F1 b, c, d, a, Xin(11), "895cd7be", 22
MD5F1 a, b, c, d, Xin(12), "6b901122", 7
MD5F1 d, a, b, c, Xin(13), "fd987193", 12
MD5F1 c, d, a, b, Xin(14), "a679438e", 17
MD5F1 b, c, d, a, Xin(15), "49b40821", 22

' 第二轮循环
MD5F2 a, b, c, d, Xin(1), "f61e2562", 5
MD5F2 d, a, b, c, Xin(6), "c040b340", 9
MD5F2 c, d, a, b, Xin(11), "265e5a51", 14
MD5F2 b, c, d, a, Xin(0), "e9b6c7aa", 20
MD5F2 a, b, c, d, Xin(5), "d62f105d", 5
MD5F2 d, a, b, c, Xin(10), "02441453", 9
MD5F2 c, d, a, b, Xin(15), "d8a1e681", 14
MD5F2 b, c, d, a, Xin(4), "e7d3fbc8", 20
MD5F2 a, b, c, d, Xin(9), "21e1cde6", 5
MD5F2 d, a, b, c, Xin(14), "c33707d6", 9
MD5F2 c, d, a, b, Xin(3), "f4d50d87", 14
MD5F2 b, c, d, a, Xin(8), "455a14ed", 20
MD5F2 a, b, c, d, Xin(13), "a9e3e905", 5
MD5F2 d, a, b, c, Xin(2), "fcefa3f8", 9
MD5F2 c, d, a, b, Xin(7), "676f02d9", 14
MD5F2 b, c, d, a, Xin(12), "8d2a4c8a", 20

' 第三轮循环
MD5F3 a, b, c, d, Xin(5), "fffa3942", 4
MD5F3 d, a, b, c, Xin(8), "8771f681", 11
MD5F3 c, d, a, b, Xin(11), "6d9d6122", 16
MD5F3 b, c, d, a, Xin(14), "fde5380c", 23
MD5F3 a, b, c, d, Xin(1), "a4beea44", 4
MD5F3 d, a, b, c, Xin(4), "4bdecfa9", 11
MD5F3 c, d, a, b, Xin(7), "f6bb4b60", 16
MD5F3 b, c, d, a, Xin(10), "bebfbc70", 23
MD5F3 a, b, c, d, Xin(13), "289b7ec6", 4
MD5F3 d, a, b, c, Xin(0), "e27fa", 11
MD5F3 c, d, a, b, Xin(3), "d4ef3085", 16
MD5F3 b, c, d, a, Xin(6), "04881d05", 23
MD5F3 a, b, c, d, Xin(9), "d9d4d039", 4
MD5F3 d, a, b, c, Xin(12), "e6db99e5", 11
MD5F3 c, d, a, b, Xin(15), "1fa27cf8", 16
MD5F3 b, c, d, a, Xin(2), "c4ac5665", 23

' 第四轮循环
MD5F4 a, b, c, d, Xin(0), "f4292244", 6
MD5F4 d, a, b, c, Xin(7), "432aff97", 10
MD5F4 c, d, a, b, Xin(14), "ab9423a7", 15
MD5F4 b, c, d, a, Xin(5), "fc93a039", 21
MD5F4 a, b, c, d, Xin(12), "655b59c3", 6
MD5F4 d, a, b, c, Xin(3), "8f0ccc92", 10
MD5F4 c, d, a, b, Xin(10), "ffeff47d", 15
MD5F4 b, c, d, a, Xin(1), "85845dd1", 21
MD5F4 a, b, c, d, Xin(8), "6fa87e4f", 6
MD5F4 d, a, b, c, Xin(15), "fe2ce6e0", 10
MD5F4 c, d, a, b, Xin(6), "a3014314", 15
MD5F4 b, c, d, a, Xin(13), "4e0811a1", 21
MD5F4 a, b, c, d, Xin(4), "f7537e82", 6
MD5F4 d, a, b, c, Xin(11), "bd3af235", 10
MD5F4 c, d, a, b, Xin(2), "2ad7d2bb", 15
MD5F4 b, c, d, a, Xin(9), "eb86d391", 21

buf(0) = BigAdd(buf(0), a)
buf(1) = BigAdd(buf(1), b)
buf(2) = BigAdd(buf(2), c)
buf(3) = BigAdd(buf(3), d)
Next loopouter

hashthis = ""
For loopit = 0 To 3
For loopinner = 3 To 0 Step -1
hashthis = hashthis + Chr(Val("&H" + Mid$(buf(loopit), 1 + 2 * loopinner, 2)))
Next loopinner
Next loopit

MD5_Calc = hashthis
End Function

Function BigMod32Add(ByVal value1 As String, ByVal value2 As String) As String
BigMod32Add = Right$(BigAdd(value1, value2), 8)
End Function

Public Function BigAdd(ByVal value1 As String, ByVal value2 As String) As String
Dim valueans As String
Dim loopit As Integer, tempnum As Integer

tempnum = Len(value1) - Len(value2)
If tempnum < 0 Then
value1 = Space$(Abs(tempnum)) + value1
ElseIf tempnum > 0 Then
value2 = Space$(Abs(tempnum)) + value2
End If

tempnum = 0
For loopit = Len(value1) To 1 Step -1
tempnum = tempnum + Val("&H" + Mid$(value1, loopit, 1)) + Val("&H" + Mid$(value2, loopit, 1))
valueans = Hex$(tempnum Mod 16) + valueans
tempnum = Int(tempnum / 16)
Next loopit

If tempnum <> 0 Then
valueans = Hex$(tempnum) + valueans
End If

BigAdd = Right(valueans, 8)
End Function

Public Function RotLeft(ByVal value1 As String, ByVal rots As Integer) As String
Dim tempstr As String
Dim loopit As Integer, loopinner As Integer
Dim tempnum As Integer

rots = rots Mod 32

If rots = 0 Then
RotLeft = value1
Exit Function
End If

value1 = Right$(value1, 8)
tempstr = String$(8 - Len(value1), "0") + value1
value1 = ""

' 转换成二进制形式
For loopit = 1 To 8
tempnum = Val("&H" + Mid$(tempstr, loopit, 1))
For loopinner = 3 To 0 Step -1
If tempnum And 2 ^ loopinner Then
value1 = value1 + "1"
Else
value1 = value1 + "0"
End If
Next loopinner
Next loopit
tempstr = Mid$(value1, rots + 1) + Left$(value1, rots)

' 转换为十六进制
value1 = ""
For loopit = 0 To 7
tempnum = 0
For loopinner = 0 To 3
If Val(Mid$(tempstr, 4 * loopit + loopinner + 1, 1)) Then

tempnum = tempnum + 2 ^ (3 - loopinner)
End If
Next loopinner
value1 = value1 + Hex$(tempnum)
Next loopit

RotLeft = Right(value1, 8)
End Function

Function BigAND(ByVal value1 As String, ByVal value2 As String) As String
Dim valueans As String
Dim loopit As Integer, tempnum As Integer

tempnum = Len(value1) - Len(value2)
If tempnum < 0 Then
value2 = Mid$(value2, Abs(tempnum) + 1)
ElseIf tempnum > 0 Then
value1 = Mid$(value1, tempnum + 1)
End If

For loopit = 1 To Len(value1)
valueans = valueans + Hex$(Val("&H" + Mid$(value1, loopit, 1)) And Val("&H" + Mid$(value2, loopit, 1)))
Next loopit

BigAND = valueans
End Function

Function BigNOT(ByVal value1 As String) As String
Dim valueans As String
Dim loopit As Integer

value1 = Right$(value1, 8)
value1 = String$(8 - Len(value1), "0") + value1
For loopit = 1 To 8
valueans = valueans + Hex$(15 Xor Val("&H" + Mid$(value1, loopit, 1)))
Next loopit

BigNOT = valueans
End Function

Function BigOR(ByVal value1 As String, ByVal value2 As String) As String
Dim valueans As String
Dim loopit As Integer, tempnum As Integer

tempnum = Len(value1) - Len(value2)
If tempnum < 0 Then
valueans = Left$(value2, Abs(tempnum))
value2 = Mid$(value2, Abs(tempnum) + 1)
ElseIf tempnum > 0 Then
valueans = Left$(value1, Abs(tempnum))
value1 = Mid$(value1, tempnum + 1)
End If

For loopit = 1 To Len(value1)
valueans = valueans + Hex$(Val("&H" + Mid$(value1, loopit, 1)) Or Val("&H" + Mid$(value2, loopit, 1)))
Next loopit

BigOR = valueans
End Function

Function BigXOR(ByVal value1 As String, ByVal value2 As String) As String
Dim valueans As String
Dim loopit As Integer, tempnum As Integer

tempnum = Len(value1) - Len(value2)
If tempnum < 0 Then
valueans = Left$(value2, Abs(tempnum))
value2 = Mid$(value2, Abs(tempnum) + 1)
ElseIf tempnum > 0 Then
valueans = Left$(value1, Abs(tempnum))
value1 = Mid$(value1, tempnum + 1)
End If

For loopit = 1 To Len(value1)
valueans = valueans + Hex$(Val("&H" + Mid$(value1, loopit, 1)) Xor Val("&H" + Mid$(value2, loopit, 1)))
Next loopit

BigXOR = Right(valueans, 8)
End Function

那就永无宁日了!