modMD5.bas

Attribute VB_Name = "Module1"
Option Explicit
Option Base 0

' Modified for qvPDF by QuoVadis

' 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.
'************************* COPYRIGHT NOTICE*************************
' This code was originally written in Visual Basic by David Ireland
' and is copyright (c) 2005 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

' MAIN EXPORTED MD5 FUNCTIONS...

Public Function MD5_bytes(strMessage As String) 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
    
    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
    
    ' 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
            MD5_bytes = MD5_bytes & Chr(wb(j))
        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

Private 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
    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
'****************************************************