' ******************* Data Validation Function ****************
' For information about this code contact VMPForms
' ammendments by Dr G. Warner for VMP 30/03/04

'**start Encode **


Private m_lOnBits(30)
Private m_l2Power(30)
Private K(63)

Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32

m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)

m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)
    
K(0) = &H428A2F98
K(1) = &H71374491
K(2) = &HB5C0FBCF
K(3) = &HE9B5DBA5
K(4) = &H3956C25B
K(5) = &H59F111F1
K(6) = &H923F82A4
K(7) = &HAB1C5ED5
K(8) = &HD807AA98
K(9) = &H12835B01
K(10) = &H243185BE
K(11) = &H550C7DC3
K(12) = &H72BE5D74
K(13) = &H80DEB1FE
K(14) = &H9BDC06A7
K(15) = &HC19BF174
K(16) = &HE49B69C1
K(17) = &HEFBE4786
K(18) = &HFC19DC6
K(19) = &H240CA1CC
K(20) = &H2DE92C6F
K(21) = &H4A7484AA
K(22) = &H5CB0A9DC
K(23) = &H76F988DA
K(24) = &H983E5152
K(25) = &HA831C66D
K(26) = &HB00327C8
K(27) = &HBF597FC7
K(28) = &HC6E00BF3
K(29) = &HD5A79147
K(30) = &H6CA6351
K(31) = &H14292967
K(32) = &H27B70A85
K(33) = &H2E1B2138
K(34) = &H4D2C6DFC
K(35) = &H53380D13
K(36) = &H650A7354
K(37) = &H766A0ABB
K(38) = &H81C2C92E
K(39) = &H92722C85
K(40) = &HA2BFE8A1
K(41) = &HA81A664B
K(42) = &HC24B8B70
K(43) = &HC76C51A3
K(44) = &HD192E819
K(45) = &HD6990624
K(46) = &HF40E3585
K(47) = &H106AA070
K(48) = &H19A4C116
K(49) = &H1E376C08
K(50) = &H2748774C
K(51) = &H34B0BCB5
K(52) = &H391C0CB3
K(53) = &H4ED8AA4A
K(54) = &H5B9CCA4F
K(55) = &H682E6FF3
K(56) = &H748F82EE
K(57) = &H78A5636F
K(58) = &H84C87814
K(59) = &H8CC70208
K(60) = &H90BEFFFA
K(61) = &HA4506CEB
K(62) = &HBEF9A3F7
K(63) = &HC67178F2

Private Function LShift(lValue, iShiftBits)
  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(lValue, iShiftBits)
  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 AddUnsigned(lX, lY)
  Dim lX4
  Dim lY4
  Dim lX8
  Dim lY8
  Dim lResult
  
  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 Ch(x, y, z)
  Ch = ((x And y) Xor ((Not x) And z))
End Function

Private Function Maj(x, y, z)
  Maj = ((x And y) Xor (x And z) Xor (y And z))
End Function

Private Function S(x, n)
  S = (RShift(x, (n And m_lOnBits(4))) Or LShift(x, (32 - (n And m_lOnBits(4)))))
End Function

Private Function R(x, n)
  R = RShift(x, CInt(n And m_lOnBits(4)))
End Function

Private Function Sigma0(x)
  Sigma0 = (S(x, 2) Xor S(x, 13) Xor S(x, 22))
End Function

Private Function Sigma1(x)
  Sigma1 = (S(x, 6) Xor S(x, 11) Xor S(x, 25))
End Function

Private Function Gamma0(x)
  Gamma0 = (S(x, 7) Xor S(x, 18) Xor R(x, 3))
End Function

Private Function Gamma1(x)
  Gamma1 = (S(x, 17) Xor S(x, 19) Xor R(x, 10))
End Function

Private Function ConvertToWordArray(sMessage)
  Dim lMessageLength
  Dim lNumberOfWords
  Dim lWordArray()
  Dim lBytePosition
  Dim lByteCount
  Dim lWordCount
  Dim lByte
  
  Const MODULUS_BITS = 512
  Const CONGRUENT_BITS = 448
  
  lMessageLength = Len(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 = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
        
    lByte = AscB(Mid(sMessage, lByteCount + 1, 1))
    
    lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(lByte, lBytePosition)
    lByteCount = lByteCount + 1
  Loop
  
  lWordCount = lByteCount \ BYTES_TO_A_WORD
  lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
  
  lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
  
  lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
  lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)
  
  ConvertToWordArray = lWordArray
End Function

Public Function Digest(sMessage,blnSafe)
'if blnSafe is true - removes vowels.
  Dim HASH(7)
  Dim M
  Dim W(63)
  Dim a
  Dim b
  Dim c
  Dim d
  Dim e
  Dim f
  Dim g
  Dim h
  Dim i
  Dim j
  Dim T1
  Dim T2
  
  HASH(0) = &H6A09E667
  HASH(1) = &HBB67AE85
  HASH(2) = &H3C6EF372
  HASH(3) = &HA54FF53A
  HASH(4) = &H510E527F
  HASH(5) = &H9B05688C
  HASH(6) = &H1F83D9AB
  HASH(7) = &H5BE0CD19
  
  M = ConvertToWordArray(sMessage)
  
  For i = 0 To UBound(M) Step 16
    a = HASH(0)
    b = HASH(1)
    c = HASH(2)
    d = HASH(3)
    e = HASH(4)
    f = HASH(5)
    g = HASH(6)
    h = HASH(7)
    
    For j = 0 To 63
      If j < 16 Then
        W(j) = M(j + i)
      Else
        W(j) = AddUnsigned(AddUnsigned(AddUnsigned(Gamma1(W(j - 2)), W(j - 7)), Gamma0(W(j - 15))), W(j - 16))
      End If
      
      T1 = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(h, Sigma1(e)), Ch(e, f, g)), K(j)), W(j))
      T2 = AddUnsigned(Sigma0(a), Maj(a, b, c))
      
      h = g
      g = f
      f = e
      e = AddUnsigned(d, T1)
      d = c
      c = b
      b = a
      a = AddUnsigned(T1, T2)
    Next
    
    HASH(0) = AddUnsigned(a, HASH(0))
    HASH(1) = AddUnsigned(b, HASH(1))
    HASH(2) = AddUnsigned(c, HASH(2))
    HASH(3) = AddUnsigned(d, HASH(3))
    HASH(4) = AddUnsigned(e, HASH(4))
    HASH(5) = AddUnsigned(f, HASH(5))
    HASH(6) = AddUnsigned(g, HASH(6))
    HASH(7) = AddUnsigned(h, HASH(7))
  Next
  ' start of GCW Modifications    
  Dim p1, p2 'part1 and part2
  p1 = HASH(0) Xor HASH(2) Xor HASH(4) Xor HASH(6)
  p2 = HASH(1) Xor HASH(3) Xor HASH(5) Xor HASH(7)
  Dim characters
  'DB up to version 11-11-09, the characters for all uses was set as  "0123456789ABCDEFGHIJKLMNPQRSTUVW"
  'from 11-11-09 onwards, the safe option was added to "0123456789BCDFGHJKLMNPQRST1VWXYZ" to remove vowel sounds - prevents chance of swear words appearing at random
  if blnSafe = true then characters = "0123456789BCDFGHJKLMNPQRST1VWXYZ"
  if blnSafe <> true then characters = "0123456789ABCDEFGHIJKLMNPQRSTUVW"
  Dim chunk(12)
  ' The first chunk is only 4 bits long, the rest are 5 bits.
  ' It must also be remembered that the digest is split into two parts and
  ' hence the right shifts reflect this
  ' The following masks are used (the leading zero removes the extra digit
  ' for the sign of the number )
  ' &H0F0000000 = 11110000000000000000000000000000
  ' &H00F800000 = 00001111100000000000000000000000
  ' &H0007C0000 = 00000000011111000000000000000000
  ' &H00003E000 = 00000000000000111110000000000000
  ' &H000001F00 = 00000000000000000001111100000000
  ' &H0000000F8 = 00000000000000000000000011111000
  ' &H000000007 = 00000000000000000000000000000111
  ' &H0C0000000 = 11000000000000000000000000000000
  ' &H03E000000 = 00111110000000000000000000000000
  ' &H001F00000 = 00000001111100000000000000000000
  ' &H0000F8000 = 00000000000011111000000000000000
  ' &H000007C00 = 00000000000000000111110000000000
  ' &H0000003E0 = 00000000000000000000001111100000
  ' &H00000001F = 00000000000000000000000000011111
  chunk(0)  = CInt(RShift(p1 And &H0F0000000,28))
  chunk(1)  = CInt(Rshift(p1 And &H00F800000,23))
  chunk(2)  = CInt(RShift(p1 And &H0007C0000,18))
  chunk(3)  = CInt(Rshift(p1 And &H00003E000,13))
  chunk(4)  = CInt(Rshift(p1 And &H000001F00,8))
  chunk(5)  = CInt(Rshift(p1 And &H0000000F8,3))
  ' chunk(6) is split across both parts
  chunk(6)  = CInt(LShift(p1 And &H000000007,2) + RShift(p2 And &H0C0000000,30))
  chunk(7)  = CInt(RShift(p2 And &H03E000000,25))
  chunk(8)  = CInt(RShift(p2 And &H001F00000,20))
  chunk(9)  = CInt(Rshift(p2 And &H0000F8000,15))
  chunk(10) = CInt(RShift(p2 And &H000007C00,10))
  chunk(11) = CInt(Rshift(p2 And &H0000003E0,5))
  chunk(12) = CInt(p2 And &H00000001F)
  Digest = ""
  For i = 0 To 12
    If chunk(i) < 0 Or chunk(i) > 31 Then chunk(i) = 0
    digest = digest & Mid(characters,chunk(i)+1,1)
  Next
  'end of GCW modifications
End Function