MD5 Message Digest Algorithm in Visual Basic 6

Attribute VB_Name = "basMD5"

Option Explicit

Option Base 0



' A VB6/VBA procedure for the MD5 message-digest algorithm

' as described in RFC 1321 by R. Rivest, April 1992



' First published 16 September 2005.

' Updated 2010-10-20 to fix ">" vs ">=" issue in uwAdd.

'  --Thanks to Loek for this.

'************************* COPYRIGHT NOTICE*************************

' This code was originally written in Visual Basic by David Ireland

' and is copyright (c) 2005-10 D.I. Management Services Pty Limited,

' all rights reserved.



' You are free to use this code as part of your own applications

' provided you keep this copyright notice intact and acknowledge

' its authorship with the words:



'   "Contains cryptography software by David Ireland of

'   DI Management Services Pty Ltd <www.di-mgt.com.au>."



' If you use it as part of a web site, please include a link

' to our site in the form

' <A HREF="http://www.di-mgt.com.au/crypto.html">Cryptography

' Software Code</a>



' This code may only be used as part of an application. It may

' not be reproduced or distributed separately by any means without

' the express written permission of the author.



' David Ireland and DI Management Services Pty Limited make no

' representations concerning either the merchantability of this

' software or the suitability of this software for any particular

' purpose. It is provided "as is" without express or implied

' warranty of any kind.



' The latest version of this source code can be downloaded from

' www.di-mgt.com.au/crypto.html.

' Comments and bug reports to http://www.di-mgt.com.au/contact.html

'****************** END OF COPYRIGHT NOTICE*************************



' POSSIBLE SPEED-UPS

' 1. Use memory copy functions from Win32 API to copy bytes into

'    32-bit words directly.

' 2. Write 16 x specific Rotate_Left_By_n functions with hardcoded

'    multiplicands for each possible shift S11..S44;

'    i.e. for n = 4-7, 9-12, 14-17, 20-23.



Private Const MD5_BLK_LEN As Long = 64

' Constants for MD5Transform routine

Private Const S11 As Long = 7

Private Const S12 As Long = 12

Private Const S13 As Long = 17

Private Const S14 As Long = 22

Private Const S21 As Long = 5

Private Const S22 As Long = 9

Private Const S23 As Long = 14

Private Const S24 As Long = 20

Private Const S31 As Long = 4

Private Const S32 As Long = 11

Private Const S33 As Long = 16

Private Const S34 As Long = 23

Private Const S41 As Long = 6

Private Const S42 As Long = 10

Private Const S43 As Long = 15

Private Const S44 As Long = 21

' Constants for unsigned word addition

Private Const OFFSET_4 = 4294967296#

Private Const MAXINT_4 = 2147483647



' TEST FUNCTIONS...

' MD5 test suite:

' MD5 ("") = d41d8cd98f00b204e9800998ecf8427e

' MD5 ("a") = 0cc175b9c0f1b6a831c399e269772661

' MD5 ("abc") = 900150983cd24fb0d6963f7d28e17f72

' MD5 ("message digest") = f96b697d7cb7938d525a2f31aaf161d0

' MD5 ("abcdefghijklmnopqrstuvwxyz") = c3fcd3d76192e4007dfb496cca67e13b

' MD5 ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") =

' d174ab98d277d9f5a5611c2c9f419d9f

' MD5 ("123456789012345678901234567890123456789012345678901234567890123456

' 78901234567890") = 57edf4a22be3c955ac49da2e2107b67a



' MD5 (1 million x 'a') = 7707d6ae4e027c70eea2a935c2296f21



Public Function Test_md5_abc()

    Debug.Print MD5_string("abc")

End Function



Public Function md5_test_suite()

    Debug.Print MD5_string("")

    Debug.Print MD5_string("a")

    Debug.Print MD5_string("abc")

    Debug.Print MD5_string("message digest")

    Debug.Print MD5_string("abcdefghijklmnopqrstuvwxyz")

    Debug.Print MD5_string("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")

    Debug.Print MD5_string("12345678901234567890123456789012345678901234567890123456789012345678901234567890")

End Function



Public Function test_md5_empty()

    Debug.Print MD5_string("")

End Function



Public Function test_md5_around64()

    Dim strMessage As String

    strMessage = "12345678901234567890123456789012345678901234567890123456789012345678901234567890"

    Debug.Print MD5_string(strMessage)

    Debug.Print MD5_string(Left(strMessage, 65))

    Debug.Print MD5_string(Left(strMessage, 64))

    Debug.Print MD5_string(Left(strMessage, 63))

    Debug.Print MD5_string(Left(strMessage, 62))

    Debug.Print MD5_string(Left(strMessage, 57))

    Debug.Print MD5_string(Left(strMessage, 56))

    Debug.Print MD5_string(Left(strMessage, 55))

End Function



Public Function test_md5_million_a()

' This may take some time...

    Dim abMessage() As Byte

    Dim mLen As Long

    Dim i As Long

    mLen = 1000000

    ReDim abMessage(mLen - 1)

    For i = 0 To mLen - 1

        abMessage(i) = &H61     ' 0x61 = 'a'

    Next

    Debug.Print MD5_bytes(abMessage, mLen)

    

End Function



' MAIN EXPORTED MD5 FUNCTIONS...



Public Function MD5_string(strMessage As String) As String

' Returns 32-char hex string representation of message digest

' Input as a string (max length 2^29-1 bytes)

    Dim abMessage() As Byte

    Dim mLen As Long

    ' Cope with the empty string

    If Len(strMessage) > 0 Then

        abMessage = StrConv(strMessage, vbFromUnicode)

        ' Compute length of message in bytes

        mLen = UBound(abMessage) - LBound(abMessage) + 1

    End If

    MD5_string = MD5_bytes(abMessage, mLen)

End Function



Public Function MD5_bytes(abMessage() As Byte, mLen As Long) As String

' Returns 32-char hex string representation of message digest

' Input as an array of bytes of length mLen bytes



    Dim nBlks As Long

    Dim nBits As Long

    Dim block(MD5_BLK_LEN - 1) As Byte

    Dim state(3) As Long

    Dim wb(3) As Byte

    Dim sHex As String

    Dim index As Long

    Dim partLen As Long

    Dim i As Long

    Dim j As Long

    

    ' Catch length too big for VB arithmetic (268 million!)

    If mLen >= &HFFFFFFF Then Error 6     ' overflow

    

    ' Initialise

    ' Number of complete 512-bit/64-byte blocks to process

    nBlks = mLen \ MD5_BLK_LEN

    

    ' Load magic initialization constants

    state(0) = &H67452301

    state(1) = &HEFCDAB89

    state(2) = &H98BADCFE

    state(3) = &H10325476

    

    ' Main loop for each complete input block of 64 bytes

    index = 0

    For i = 0 To nBlks - 1

        Call md5_transform(state, abMessage, index)

        index = index + MD5_BLK_LEN

    Next

    

    ' Construct final block(s) with padding

    partLen = mLen Mod MD5_BLK_LEN

    index = nBlks * MD5_BLK_LEN

    For i = 0 To partLen - 1

        block(i) = abMessage(index + i)

    Next

    block(partLen) = &H80

    ' Make sure padding (and bit-length) set to zero

    For i = partLen + 1 To MD5_BLK_LEN - 1

        block(i) = 0

    Next

    ' Two cases: partLen is < or >= 56

    If partLen >= MD5_BLK_LEN - 8 Then

        ' Need two blocks

        Call md5_transform(state, block, 0)

        For i = 0 To MD5_BLK_LEN - 1

            block(i) = 0

        Next

    End If

    ' Append number of bits in little-endian order

    nBits = mLen * 8

    block(MD5_BLK_LEN - 8) = nBits And &HFF

    block(MD5_BLK_LEN - 7) = nBits \ &H100 And &HFF

    block(MD5_BLK_LEN - 6) = nBits \ &H10000 And &HFF

    block(MD5_BLK_LEN - 5) = nBits \ &H1000000 And &HFF

    ' (NB we don't try to cope with number greater than 2^31)

    

    ' Final padded block with bit length

    Call md5_transform(state, block, 0)

    

    ' Decode 4 x 32-bit words into 16 bytes with LSB first each time

    ' and return result as a hex string

    MD5_bytes = ""

    For i = 0 To 3

        Call uwSplit(state(i), wb(3), wb(2), wb(1), wb(0))

        For j = 0 To 3

            If wb(j) < 16 Then

                sHex = "0" & Hex(wb(j))

            Else

                sHex = Hex(wb(j))

            End If

            MD5_bytes = MD5_bytes & sHex

        Next

    Next

    

End Function



' INTERNAL FUNCTIONS...



Private Sub md5_transform(state() As Long, buf() As Byte, ByVal index As Long)

' Updates 4 x 32-bit values in state

' Input: the next 64 bytes in buf starting at offset index

' Assumes at least 64 bytes are present after offset index

    Dim a As Long

    Dim b As Long

    Dim c As Long

    Dim d As Long

    Dim j As Integer

    Dim x(15) As Long

    

    a = state(0)

    b = state(1)

    c = state(2)

    d = state(3)

    

    ' Decode the next 64 bytes into 16 words with LSB first

    For j = 0 To 15

        x(j) = uwJoin(buf(index + 3), buf(index + 2), buf(index + 1), buf(index))

        index = index + 4

    Next

    

    ' Round 1

    a = FF(a, b, c, d, x(0), S11, &HD76AA478)   ' 1

    d = FF(d, a, b, c, x(1), S12, &HE8C7B756)   ' 2

    c = FF(c, d, a, b, x(2), S13, &H242070DB)   ' 3

    b = FF(b, c, d, a, x(3), S14, &HC1BDCEEE)   ' 4

    a = FF(a, b, c, d, x(4), S11, &HF57C0FAF)   ' 5

    d = FF(d, a, b, c, x(5), S12, &H4787C62A)   ' 6

    c = FF(c, d, a, b, x(6), S13, &HA8304613)   ' 7

    b = FF(b, c, d, a, x(7), S14, &HFD469501)   ' 8

    a = FF(a, b, c, d, x(8), S11, &H698098D8)   ' 9

    d = FF(d, a, b, c, x(9), S12, &H8B44F7AF)   ' 10

    c = FF(c, d, a, b, x(10), S13, &HFFFF5BB1)  ' 11

    b = FF(b, c, d, a, x(11), S14, &H895CD7BE)  ' 12

    a = FF(a, b, c, d, x(12), S11, &H6B901122)  ' 13

    d = FF(d, a, b, c, x(13), S12, &HFD987193)  ' 14

    c = FF(c, d, a, b, x(14), S13, &HA679438E)  ' 15

    b = FF(b, c, d, a, x(15), S14, &H49B40821)  ' 16

    

    ' Round 2

    a = GG(a, b, c, d, x(1), S21, &HF61E2562)   ' 17

    d = GG(d, a, b, c, x(6), S22, &HC040B340)   ' 18

    c = GG(c, d, a, b, x(11), S23, &H265E5A51)  ' 19

    b = GG(b, c, d, a, x(0), S24, &HE9B6C7AA)   ' 20

    a = GG(a, b, c, d, x(5), S21, &HD62F105D)   ' 21

    d = GG(d, a, b, c, x(10), S22, &H2441453)   ' 22

    c = GG(c, d, a, b, x(15), S23, &HD8A1E681)  ' 23

    b = GG(b, c, d, a, x(4), S24, &HE7D3FBC8)   ' 24

    a = GG(a, b, c, d, x(9), S21, &H21E1CDE6)   ' 25

    d = GG(d, a, b, c, x(14), S22, &HC33707D6)  ' 26

    c = GG(c, d, a, b, x(3), S23, &HF4D50D87)   ' 27

    b = GG(b, c, d, a, x(8), S24, &H455A14ED)   ' 28

    a = GG(a, b, c, d, x(13), S21, &HA9E3E905)  ' 29

    d = GG(d, a, b, c, x(2), S22, &HFCEFA3F8)   ' 30

    c = GG(c, d, a, b, x(7), S23, &H676F02D9)   ' 31

    b = GG(b, c, d, a, x(12), S24, &H8D2A4C8A)  ' 32

    

    ' Round 3

    a = HH(a, b, c, d, x(5), S31, &HFFFA3942)   ' 33

    d = HH(d, a, b, c, x(8), S32, &H8771F681)   ' 34

    c = HH(c, d, a, b, x(11), S33, &H6D9D6122)  ' 35

    b = HH(b, c, d, a, x(14), S34, &HFDE5380C)  ' 36

    a = HH(a, b, c, d, x(1), S31, &HA4BEEA44)   ' 37

    d = HH(d, a, b, c, x(4), S32, &H4BDECFA9)   ' 38

    c = HH(c, d, a, b, x(7), S33, &HF6BB4B60)   ' 39

    b = HH(b, c, d, a, x(10), S34, &HBEBFBC70)  ' 40

    a = HH(a, b, c, d, x(13), S31, &H289B7EC6)  ' 41

    d = HH(d, a, b, c, x(0), S32, &HEAA127FA)   ' 42

    c = HH(c, d, a, b, x(3), S33, &HD4EF3085)   ' 43

    b = HH(b, c, d, a, x(6), S34, &H4881D05)    ' 44

    a = HH(a, b, c, d, x(9), S31, &HD9D4D039)   ' 45

    d = HH(d, a, b, c, x(12), S32, &HE6DB99E5)  ' 46

    c = HH(c, d, a, b, x(15), S33, &H1FA27CF8)  ' 47

    b = HH(b, c, d, a, x(2), S34, &HC4AC5665)   ' 48

    

    ' Round 4

    a = II(a, b, c, d, x(0), S41, &HF4292244)   ' 49

    d = II(d, a, b, c, x(7), S42, &H432AFF97)   ' 50

    c = II(c, d, a, b, x(14), S43, &HAB9423A7)  ' 51

    b = II(b, c, d, a, x(5), S44, &HFC93A039)   ' 52

    a = II(a, b, c, d, x(12), S41, &H655B59C3)  ' 53

    d = II(d, a, b, c, x(3), S42, &H8F0CCC92)   ' 54

    c = II(c, d, a, b, x(10), S43, &HFFEFF47D)  ' 55

    b = II(b, c, d, a, x(1), S44, &H85845DD1)   ' 56

    a = II(a, b, c, d, x(8), S41, &H6FA87E4F)   ' 57

    d = II(d, a, b, c, x(15), S42, &HFE2CE6E0)  ' 58

    c = II(c, d, a, b, x(6), S43, &HA3014314)   ' 59

    b = II(b, c, d, a, x(13), S44, &H4E0811A1)  ' 60

    a = II(a, b, c, d, x(4), S41, &HF7537E82)   ' 61

    d = II(d, a, b, c, x(11), S42, &HBD3AF235)  ' 62

    c = II(c, d, a, b, x(2), S43, &H2AD7D2BB)   ' 63

    b = II(b, c, d, a, x(9), S44, &HEB86D391)   ' 64

    

    state(0) = uwAdd(state(0), a)

    state(1) = uwAdd(state(1), b)

    state(2) = uwAdd(state(2), c)

    state(3) = uwAdd(state(3), d)



End Sub



' FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4



Private Function AddRotAdd(f As Long, a As Long, b As Long, x As Long, s As Integer, ac As Long) As Long

' Common routine for FF, GG, HH and II

' #define AddRotAdd(f, a, b, c, d, x, s, ac) { \

'  (a) += f + (x) + (UINT4)(ac); \

'  (a) = ROTATE_LEFT ((a), (s)); \

'  (a) += (b); \

'  }

    Dim temp As Long

    temp = uwAdd(a, f)

    temp = uwAdd(temp, x)

    temp = uwAdd(temp, ac)

    temp = uwRol(temp, s)

    AddRotAdd = uwAdd(temp, b)

End Function



Private Function FF(a As Long, b As Long, c As Long, d As Long, x As Long, s As Integer, ac As Long) As Long

' Returns new value of a

' #define F(x, y, z) (((x) & (y)) | ((~x) & (z)))

' #define FF(a, b, c, d, x, s, ac) { \

'  (a) += F ((b), (c), (d)) + (x) + (UINT4)(ac); \

'  (a) = ROTATE_LEFT ((a), (s)); \

'  (a) += (b); \

'  }

    Dim t As Long

    Dim t2 As Long

    ' F ((b), (c), (d)) = (((b) & (c)) | ((~b) & (d)))

    t = b And c

    t2 = (Not b) And d

    t = t Or t2

    FF = AddRotAdd(t, a, b, x, s, ac)

End Function



Private Function GG(a As Long, b As Long, c As Long, d As Long, x As Long, s As Integer, ac As Long) As Long

' #define G(b, c, d) (((b) & (d)) | ((c) & (~d)))

    Dim t As Long

    Dim t2 As Long

    t = b And d

    t2 = c And (Not d)

    t = t Or t2

    GG = AddRotAdd(t, a, b, x, s, ac)

End Function



Private Function HH(a As Long, b As Long, c As Long, d As Long, x As Long, s As Integer, ac As Long) As Long

' #define H(b, c, d) ((b) ^ (c) ^ (d))

    Dim t As Long

    t = b Xor c Xor d

    HH = AddRotAdd(t, a, b, x, s, ac)

End Function



Private Function II(a As Long, b As Long, c As Long, d As Long, x As Long, s As Integer, ac As Long) As Long

' #define I(b, c, d) ((c) ^ ((b) | (~d)))

    Dim t As Long

    t = b Or (Not d)

    t = c Xor t

    II = AddRotAdd(t, a, b, x, s, ac)

End Function



' Unsigned 32-bit word functions suitable for VB/VBA



Private Function uwRol(w As Long, s As Integer) As Long

' Return 32-bit word w rotated left by s bits

' avoiding problem with VB sign bit

    Dim i As Integer

    Dim t As Long

    

    uwRol = w

    For i = 1 To s

        t = uwRol And &H3FFFFFFF

        t = t * 2

        If (uwRol And &H40000000) <> 0 Then

            t = t Or &H80000000

        End If

        If (uwRol And &H80000000) <> 0 Then

            t = t Or &H1

        End If

        uwRol = t

    Next

End Function



Private Function uwJoin(a As Byte, b As Byte, c As Byte, d As Byte) As Long

' Join 4 x 8-bit bytes into one 32-bit word a.b.c.d

    uwJoin = ((a And &H7F) * &H1000000) Or (b * &H10000) Or (CLng(c) * &H100) Or d

    If a And &H80 Then

        uwJoin = uwJoin Or &H80000000

    End If

End Function



Private Sub uwSplit(ByVal w As Long, a As Byte, b As Byte, c As Byte, d As Byte)

' Split 32-bit word w into 4 x 8-bit bytes

    a = CByte(((w And &HFF000000) \ &H1000000) And &HFF)

    b = CByte(((w And &HFF0000) \ &H10000) And &HFF)

    c = CByte(((w And &HFF00) \ &H100) And &HFF)

    d = CByte((w And &HFF) And &HFF)

End Sub



Public Function uwAdd(wordA As Long, wordB As Long) As Long

' Adds words A and B avoiding overflow

    Dim myUnsigned As Double

    

    myUnsigned = LongToUnsigned(wordA) + LongToUnsigned(wordB)

    ' Cope with overflow

    '[2010-10-20] Changed from ">" to ">=". Thanks Loek.

    If myUnsigned >= OFFSET_4 Then

        myUnsigned = myUnsigned - OFFSET_4

    End If

    uwAdd = UnsignedToLong(myUnsigned)

    

End Function



'****************************************************

' These two functions from Microsoft Article Q189323

' "HOWTO: convert between Signed and Unsigned Numbers"



Private Function UnsignedToLong(value As Double) As Long

    If value < 0 Or value >= OFFSET_4 Then Error 6 ' Overflow

    If value <= MAXINT_4 Then

        UnsignedToLong = value

    Else

        UnsignedToLong = value - OFFSET_4

    End If

End Function



Private Function LongToUnsigned(value As Long) As Double

    If value < 0 Then

        LongToUnsigned = value + OFFSET_4

    Else

        LongToUnsigned = value

    End If

End Function



' End of Microsoft-article functions

'****************************************************

　　

以下是我调用vb.net实现，需要引用一下.net类库:

Public Function GetMD5Hash(ByVal StrToHash As String) As String

    Dim BytestoHash() As Byte

    Dim b As Variant

    Dim StrResult As String

    Dim Text As Object

    Dim SHA512 As Object

    Set Text = CreateObject("System.Text.UTF8Encoding")

    Set MD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")

    BytestoHash = Text.GetBytes_4(StrToHash)

    BytestoHash = MD5.ComputeHash_2(BytestoHash)

    For i = LBound(BytestoHash) To UBound(BytestoHash)

        StrResult = StrResult & Format(Hex(BytestoHash(i)), "00")

    Next

    GetMD5Hash = StrResult

End Function

　　

refer to:http://www.di-mgt.com.au/crypto.html