image
 
image
M031_Digest.bas


' ========================================================================================================================
'                                 ____,__,  __,  ____,_,  _,  ____ ____,__, ,____,____,
'                                (-/_|(-|  (-|  (-|_,(-|\ |  (-|__|-/_|( |_/(-|_,(-|__)
'                                _/  |,_|__,_|__,_|__,_| \|,  _|__)/  |,_| \,_|__,_|  \,
'
'                                             Copyright 2011 Allen Baker
'
' ------------------------------------------------------------------------------------------------------------------------
' File:          M031_Digest
' Originator:    Allen Baker (2011.03.07 15:45)
' ------------------------------------------------------------------------------------------------------------------------
' $RCSfile$
' $Revision$
' $Date$
' ========================================================================================================================
Option Explicit
Option Base 0



' ========================================================================================================================
' Description
'    This module contains VBA routines for generating digests.  It currently supports these digest algorithms:
'       MD5 message-digest algorithm as described in RFC 1321 by R. Rivest, April 1992
'
'            The MD5 algorithm produces a 128 bit digital fingerprint (signature) from a dataset of arbitrary length. It
'            is conjectured that it is computationally infeasible to produce two messages having the same MD5 digest, or
'            to produce any message having a given prespecified target message digest. 128 bits allows for an enormous
'            number of possible fingerprints, actually
'
'               340,282,366,920,938,463,463,374,607,431,768,211,456
'
'            different fingerprints. The total number of words ever spoken by all the human beings that have ever lived
'            is about 5 exawords or
'
'                                         5,000,000,000,000,000,000
'
'            words. If every one of those words ever spoken was unique - no word was ever spoken twice, a 128 bit
'            fingerprint could be computed for every word ever spoken using the MD5 algorithm with virtually no
'            possibility of a single collision.
' ========================================================================================================================



' =====================================================================================================================
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@[  Constants  ]@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' =====================================================================================================================



Private Const MD5_BLK_LEN As Long = 64
'
' ==============================================================================================
' Constants for the transform 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



' =====================================================================================================================
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@[  Module Variables  ]@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' =====================================================================================================================



' =====================================================================================================================
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@[  Public Routines  ]@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' =====================================================================================================================



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns a 32 character hex string representation of an MD5 digest of a string
'
' return
'    this function returns a 32 character hex string representation of an MD5 digest of a string
'
' param
'    pString is the string to compute the MD5 digest of
' -----------------------------------------------------------------------------------------------------------
Public Function stringToMD5(pString As String) As String
   Dim byteArray() As Byte
   Dim arrayLength As Long
   If Len(pString) > 0 Then
      byteArray = StrConv(pString, vbFromUnicode)
      arrayLength = UBound(byteArray) - LBound(byteArray) + 1
   End If
   stringToMD5 = bytesToMD5(byteArray, arrayLength)
End Function



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns a 32 character hex string representation of an MD5 digest of an array of bytes
'
' return
'    this function returns a 32 character hex string representation of an MD5 digest of an array of bytes
'
' param
'    pByteArray is the array of bytes to compute the MD5 digest of
' param
'    pArrayLength is the length of the array of bytes to compute the MD5 digest of
' -----------------------------------------------------------------------------------------------------------
Public Function bytesToMD5(pByteArray() As Byte, pArrayLength As Long) As String
   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 pArrayLength >= &HFFFFFFF Then Error 6     ' overflow
   '
   ' ==============================================================================================
   ' Number of complete 512-bit/64-byte blocks to process
   ' ----------------------------------------------------------------------------------------------
   nBlks = pArrayLength \ 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 transform(state, pByteArray, index)
      index = index + MD5_BLK_LEN
   Next
   '
   ' ==============================================================================================
   ' Construct final block(s) with padding
   ' ----------------------------------------------------------------------------------------------
   partLen = pArrayLength Mod MD5_BLK_LEN
   index = nBlks * MD5_BLK_LEN
   For i = 0 To partLen - 1
      block(i) = pByteArray(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
   ' Need two blocks
   ' ----------------------------------------------------------------------------------------------
   If partLen >= MD5_BLK_LEN - 8 Then
      Call 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 = pArrayLength * 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
   '
   ' ==============================================================================================
   ' Final padded block with bit length
   ' ----------------------------------------------------------------------------------------------
   Call 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
   ' ----------------------------------------------------------------------------------------------
   bytesToMD5 = ""
   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
         bytesToMD5 = bytesToMD5 & sHex
      Next
   Next
End Function



' =====================================================================================================================
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@[  Private Routines  ]@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' =====================================================================================================================



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This subroutine Updates 4 x 32-bit values.  It assumes at least 64 bytes are present after offset index.
'     reality check: frankly, only God and the egghead that invented MD5 have any clue what this transform
'     does.
'
' param
'    pState is an array of state values
' param
'    pBuf is the array of bytes to transform
' param
'    pIndex is the index into pBuf to start at
' -----------------------------------------------------------------------------------------------------------
Private Sub transform(state() As Long, buf() As Byte, ByVal index As Long)
   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



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' -----------------------------------------------------------------------------------------------------------
Private Function addRotAdd(f As Long, a As Long, b As Long, x As Long, s As Integer, ac As Long) As Long
   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
   Dim t As Long
   Dim t2 As Long
   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
   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
   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
   Dim t As Long
   t = b Or (Not d)
   t = c Xor t
   II = addRotAdd(t, a, b, x, s, ac)
End Function



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns a 32-bit word w rotated left by s bits
'
' return
'    this function returns a 32-bit word w rotated left by s bits
'
' param
'    pW is the 32-bit word to rotate
' param
'    pS is the number of bits to rotate pW by
' -----------------------------------------------------------------------------------------------------------
Private Function uwRol(w As Long, s As Integer) As Long
   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



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function joins 4 x 8-bit bytes into one 32-bit word a.b.c.d
'
' return
'    this function returns the 32-bit joined word
'
' param
'    a,b,c, and d are the 8-bits words to join together
' -----------------------------------------------------------------------------------------------------------
Private Function uwJoin(a As Byte, b As Byte, c As Byte, d As Byte) As Long
   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



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This subroutine splits one 32-bit word into 4 x 8-bit bytes
'
' param
'    w is the 32-bit word to split
' param
'    a,b,c, and d are the resulting 8-bits words
' -----------------------------------------------------------------------------------------------------------
Private Sub uwSplit(ByVal w As Long, a As Byte, b As Byte, c As Byte, d As Byte)
   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



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function adds two unsigned words.
'
' return
'    this function returns the result of the addition
'
' param
'    wordA and wordB are the words to add
' -----------------------------------------------------------------------------------------------------------
Public Function uwAdd(wordA As Long, wordB As Long) As Long
   Dim myUnsigned As Double
   myUnsigned = longToUnsigned(wordA) + longToUnsigned(wordB)
   If myUnsigned >= OFFSET_4 Then
      myUnsigned = myUnsigned - OFFSET_4
   End If
   uwAdd = unsignedToLong(myUnsigned)
End Function



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function converts an unsigned number to a Long
'
' return
'    this function returns the converted unsigned value as a Long
'
' param
'    value is the unsigned value to convert
' -----------------------------------------------------------------------------------------------------------
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



' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function converts Long to an unsigned number
'
' return
'    this function returns the converted Long as an unsigned value
'
' param
'    value is the Long to convert
' -----------------------------------------------------------------------------------------------------------
Private Function longToUnsigned(value As Long) As Double
   If value < 0 Then
      longToUnsigned = value + OFFSET_4
   Else
      longToUnsigned = value
   End If
End Function