Calculating a keyed hmac sha256 in vba

    Dim bKey1() As Byte
    Dim bKey2() As Byte
    Dim bSHA() As Byte
    Dim lngLoop As Long
    bKey1 = StrConv("0PN5J17HBGZHT7JJ3X82", vbFromUnicode)
    bKey2 = StrConv("0PN5J17HBGZHT7JJ3X82", vbFromUnicode)
    For lngLoop = 0 To UBound(bKey1)
        bKey1(lngLoop) = bKey1(lngLoop) Xor &H36
    Next
    For lngLoop = 0 To UBound(bKey2)
        bKey2(lngLoop) = bKey2(lngLoop) Xor &H5C
    Next
    bSHA = SHA_routine(StrConv(bKey2, vbUnicode) & StrConv(SHA_routine(StrConv(bKey1, vbUnicode) & "Now is the time for all")))
'bSHA needs to be rendered as a Base64 string

Select allOpen in new window

    Dim bKey1() As Byte
    Dim bKey2() As Byte
    Dim bSHA() As Byte
    Dim lngLoop As Long
    Dim lngPosn As Long
    bKey1 = StrConv("0PN5J17HBGZHT7JJ3X82", vbFromUnicode)
    bKey2 = StrConv("0PN5J17HBGZHT7JJ3X82", vbFromUnicode)
    For lngLoop = 0 To UBound(bKey1)
        bKey1(lngLoop) = bKey1(lngLoop) Xor &H36
    Next
    For lngLoop = 0 To UBound(bKey2)
        bKey2(lngLoop) = bKey2(lngLoop) Xor &H5C
    Next
    
    Dim oUTF, oEnc
    Dim ipad() As Byte, opad() As Byte
    Dim strText As String
    Dim strTemp As String
 
    strText = "Now is the time for all"
     
    'Borrow some objects from .NET (supported from 1.1 onwards)
    Set oUTF = CreateObject("System.Text.UTF8Encoding")
    
    Set oEnc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    
    'Convert the string to a byte array and hash it
    ipad = oEnc.ComputeHash_2(oUTF.GetBytes_4(StrConv(bKey1, vbUnicode) & strText))
    opad = oEnc.ComputeHash_2(oUTF.GetBytes_4(StrConv(bKey2, vbUnicode) & StrConv(ipad, vbUnicode)))
    
    'Convert the byte array to a hex string
    For lngPosn = 0 To UBound(opad)
      strTemp = strTemp & UCase(Right("0" & Hex(opad(lngPosn)), 2))
    Next

Select allOpen in new window

 
public Sub ABC(s as string, Optional k as string)
Dim sHMAC as string
dim sBase64 as string

If IsNull(k) Then
  sHMAC = Hashing.SHA(s)
Else
  sHMAC = Hashing.HMAC(s, k)
End If

  sBase64 = Base64EncodeString(sHMAC )
End Sub

Select allOpen in new window

Option Compare Database
Option Explicit




    Public Function SHA(ByVal sMessage) As String
        Dim i, result(32), Temp(8) As Double, fraccubeprimes, hashValues
        Dim done512, index512, words(64) As Double, index32, mask(4)
        Dim s0, s1, t1, t2, maj, ch, strLen
     
        mask(0) = 4294967296#
        mask(1) = 16777216
        mask(2) = 65536
        mask(3) = 256
     
        hashValues = Array( _
            1779033703, 3144134277#, 1013904242, 2773480762#, _
            1359893119, 2600822924#, 528734635, 1541459225)
     
        fraccubeprimes = Array( _
            1116352408, 1899447441, 3049323471#, 3921009573#, 961987163, 1508970993, 2453635748#, 2870763221#, _
            3624381080#, 310598401, 607225278, 1426881987, 1925078388, 2162078206#, 2614888103#, 3248222580#, _
            3835390401#, 4022224774#, 264347078, 604807628, 770255983, 1249150122, 1555081692, 1996064986, _
            2554220882#, 2821834349#, 2952996808#, 3210313671#, 3336571891#, 3584528711#, 113926993, 338241895, _
            666307205, 773529912, 1294757372, 1396182291, 1695183700, 1986661051, 2177026350#, 2456956037#, _
            2730485921#, 2820302411#, 3259730800#, 3345764771#, 3516065817#, 3600352804#, 4094571909#, 275423344, _
            430227734, 506948616, 659060556, 883997877, 958139571, 1322822218, 1537002063, 1747873779, _
            1955562222, 2024104815, 2227730452#, 2361852424#, 2428436474#, 2756734187#, 3204031479#, 3329325298#)
     
        sMessage = Nz(sMessage, "")
        strLen = Len(sMessage) * 8
        sMessage = sMessage & Chr(128)
        done512 = False
        index512 = 0
     
        If (Len(sMessage) Mod 60) <> 0 Then
            For i = (Len(sMessage) Mod 60) To 59
                sMessage = sMessage & Chr(0)
            Next
        End If
     
        sMessage = sMessage & Chr(Int((strLen / mask(0) - Int(strLen / mask(0))) * 256))
        sMessage = sMessage & Chr(Int((strLen / mask(1) - Int(strLen / mask(1))) * 256))
        sMessage = sMessage & Chr(Int((strLen / mask(2) - Int(strLen / mask(2))) * 256))
        sMessage = sMessage & Chr(Int((strLen / mask(3) - Int(strLen / mask(3))) * 256))
     
        Do Until done512
            For i = 0 To 15
                words(i) = Asc(Mid(sMessage, i * 4 + 1, 1)) * mask(1) + Asc(Mid(sMessage, i * 4 + 2, 1)) * mask(2) + Asc(Mid(sMessage, i * 4 + 3, 1)) * mask(3) + Asc(Mid(sMessage, i * 4 + 4, 1))
            Next
     
            For i = 16 To 63
                s0 = largeXor(largeXor(rightRotate(words(i - 15), 7, 32), rightRotate(words(i - 15), 18, 32), 32), Int(words(i - 15) / 8), 32)
                s1 = largeXor(largeXor(rightRotate(words(i - 2), 17, 32), rightRotate(words(i - 2), 19, 32), 32), Int(words(i - 2) / 1024), 32)
                words(i) = Mod32Bit(words(i - 16) + s0 + words(i - 7) + s1)
            Next
     
            For i = 0 To 7
                Temp(i) = hashValues(i)
            Next
     
            For i = 0 To 63
                s0 = largeXor(largeXor(rightRotate(Temp(0), 2, 32), rightRotate(Temp(0), 13, 32), 32), rightRotate(Temp(0), 22, 32), 32)
                maj = largeXor(largeXor(largeAnd(Temp(0), Temp(1), 32), largeAnd(Temp(0), Temp(2), 32), 32), largeAnd(Temp(1), Temp(2), 32), 32)
                t2 = Mod32Bit(s0 + maj)
                s1 = largeXor(largeXor(rightRotate(Temp(4), 6, 32), rightRotate(Temp(4), 11, 32), 32), rightRotate(Temp(4), 25, 32), 32)
                ch = largeXor(largeAnd(Temp(4), Temp(5), 32), largeAnd(largeNot(Temp(4), 32), Temp(6), 32), 32)
                t1 = Mod32Bit(Temp(7) + s1 + ch + fraccubeprimes(i) + words(i))
     
                Temp(7) = Temp(6)
                Temp(6) = Temp(5)
                Temp(5) = Temp(4)
                Temp(4) = Mod32Bit(Temp(3) + t1)
                Temp(3) = Temp(2)
                Temp(2) = Temp(1)
                Temp(1) = Temp(0)
                Temp(0) = Mod32Bit(t1 + t2)
            Next
     
            For i = 0 To 7
                hashValues(i) = Mod32Bit(hashValues(i) + Temp(i))
            Next
     
            If (index512 + 1) * 64 >= Len(sMessage) Then done512 = True
            index512 = index512 + 1
        Loop
     
        For i = 0 To 31
            result(i) = Int((hashValues(i \ 4) / mask(i Mod 4) - Int(hashValues(i \ 4) / mask(i Mod 4))) * 256)
          '  Debug.Print result(i);
        Next
            Debug.Print vbCrLf
     For i = 0 To 31
         '   Debug.Print Hex(result(i));
            SHA = SHA & Hex(result(i))
        Next
        
        
    End Function
     
    Function Mod32Bit(value)
        Mod32Bit = Int((value / 4294967296# - Int(value / 4294967296#)) * 4294967296#)
    End Function
     
    Function rightRotate(value, amount, totalBits)
        'To leftRotate, make amount = totalBits - amount
        Dim i
        rightRotate = 0
     
        For i = 0 To (totalBits - 1)
            If i >= amount Then
                rightRotate = rightRotate + (Int((value / (2 ^ (i + 1)) - Int(value / (2 ^ (i + 1)))) * 2)) * 2 ^ (i - amount)
            Else
                rightRotate = rightRotate + (Int((value / (2 ^ (i + 1)) - Int(value / (2 ^ (i + 1)))) * 2)) * 2 ^ (totalBits - amount + i)
            End If
        Next
    End Function
     
    Function largeXor(value, xorValue, totalBits)
        Dim i, a, b
        largeXor = 0
     
        For i = 0 To (totalBits - 1)
            a = (Int((value / (2 ^ (i + 1)) - Int(value / (2 ^ (i + 1)))) * 2))
            b = (Int((xorValue / (2 ^ (i + 1)) - Int(xorValue / (2 ^ (i + 1)))) * 2))
            If a <> b Then
                largeXor = largeXor + 2 ^ i
            End If
        Next
    End Function
     
    Function largeNot(value, totalBits)
        Dim i, a
        largeNot = 0
     
        For i = 0 To (totalBits - 1)
            a = Int((value / (2 ^ (i + 1)) - Int(value / (2 ^ (i + 1)))) * 2)
            If a = 0 Then
                largeNot = largeNot + 2 ^ i
            End If
        Next
    End Function
     
    Function largeAnd(value, andValue, totalBits)
        Dim i, a, b
        largeAnd = 0
     
        For i = 0 To (totalBits - 1)
            a = Int((value / (2 ^ (i + 1)) - Int(value / (2 ^ (i + 1)))) * 2)
            b = (Int((andValue / (2 ^ (i + 1)) - Int(andValue / (2 ^ (i + 1)))) * 2))
            If a = 1 And b = 1 Then
                largeAnd = largeAnd + 2 ^ i
            End If
        Next
    End Function
     



Public Function HMAC(s As String, k As String) As String


Dim i  As Integer
Dim bKey1() As Byte
    Dim bKey2() As Byte
    Dim bSHA() As Byte
    Dim lngLoop As Long
    'bKey1 = StrConv("0PN5J17HBGZHT7JJ3X82", vbFromUnicode)
    'bKey2 = StrConv("0PN5J17HBGZHT7JJ3X82", vbFromUnicode)
    bKey1 = StrConv(k, vbFromUnicode)
    bKey2 = StrConv(k, vbFromUnicode)
    For lngLoop = 0 To UBound(bKey1)
        bKey1(lngLoop) = bKey1(lngLoop) Xor &H36
    Next
    For lngLoop = 0 To UBound(bKey2)
        bKey2(lngLoop) = bKey2(lngLoop) Xor &H5C
    Next
    HMAC = SHA(StrConv(bKey2, vbUnicode) & StrConv(SHA(StrConv(bKey1, vbUnicode) & s), vbUnicode))
'bSHA needs to be rendered as a Base64 string


        
        
        
End Function

Select allOpen in new window

Option Compare Database
Option Explicit

' A Base64 Encoder/Decoder.
'
' This module is used to encode and decode data in Base64 format as described in RFC 1521.
'
' Home page: www.source-code.biz.
' License: GNU/LGPL (www.gnu.org/licenses/lgpl.html).
' Copyright 2007: Christian d'Heureuse, Inventec Informatik AG, Switzerland.
' This module is provided "as is" without warranty of any kind.

Private InitDone  As Boolean
Private Map1(0 To 63)  As Byte
Private Map2(0 To 127) As Byte

' Encodes a string into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
'   S         a String to be encoded.
' Returns:    a String with the Base64 encoded data.
Public Function Base64EncodeString(ByVal s As String) As String
   Base64EncodeString = Base64Encode(ConvertStringToBytes(s))
   End Function

' Encodes a byte array into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
'   InData    an array containing the data bytes to be encoded.
' Returns:    a string with the Base64 encoded data.
Public Function Base64Encode(InData() As Byte)
   Base64Encode = Base64Encode2(InData, UBound(InData) - LBound(InData) + 1)
   End Function

' Encodes a byte array into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
'   InData    an array containing the data bytes to be encoded.
'   InLen     number of bytes to process in InData.
' Returns:    a string with the Base64 encoded data.
Public Function Base64Encode2(InData() As Byte, ByVal InLen As Long) As String
   If Not InitDone Then Init
   If InLen = 0 Then Base64Encode2 = "": Exit Function
   Dim ODataLen As Long: ODataLen = (InLen * 4 + 2) \ 3     ' output length without padding
   Dim OLen As Long: OLen = ((InLen + 2) \ 3) * 4           ' output length including padding
   Dim Out() As Byte
   ReDim Out(0 To OLen - 1) As Byte
   Dim ip0 As Long: ip0 = LBound(InData)
   Dim ip As Long
   Dim op As Long
   Do While ip < InLen
      Dim i0 As Byte: i0 = InData(ip0 + ip): ip = ip + 1
      Dim i1 As Byte: If ip < InLen Then i1 = InData(ip0 + ip): ip = ip + 1 Else i1 = 0
      Dim i2 As Byte: If ip < InLen Then i2 = InData(ip0 + ip): ip = ip + 1 Else i2 = 0
      Dim o0 As Byte: o0 = i0 \ 4
      Dim o1 As Byte: o1 = ((i0 And 3) * &H10) Or (i1 \ &H10)
      Dim o2 As Byte: o2 = ((i1 And &HF) * 4) Or (i2 \ &H40)
      Dim o3 As Byte: o3 = i2 And &H3F
      Out(op) = Map1(o0): op = op + 1
      Out(op) = Map1(o1): op = op + 1
      Out(op) = IIf(op < ODataLen, Map1(o2), Asc("=")): op = op + 1
      Out(op) = IIf(op < ODataLen, Map1(o3), Asc("=")): op = op + 1
      Loop
   Base64Encode2 = ConvertBytesToString(Out)
   End Function

' Decodes a string from Base64 format.
' Parameters:
'    s        a Base64 String to be decoded.
' Returns     a String containing the decoded data.
Public Function Base64DecodeString(ByVal s As String) As String
   If s = "" Then Base64DecodeString = "": Exit Function
   Base64DecodeString = ConvertBytesToString(Base64Decode(s))
   End Function

' Decodes a byte array from Base64 format.
' Parameters
'   s         a Base64 String to be decoded.
' Returns:    an array containing the decoded data bytes.
Public Function Base64Decode(ByVal s As String) As Byte()
   If Not InitDone Then Init
   Dim iBuf() As Byte: iBuf = ConvertStringToBytes(s)
   Dim iLen As Long: iLen = UBound(iBuf) + 1
   If iLen Mod 4 <> 0 Then err.Raise vbObjectError, , "Length of Base64 encoded input string is not a multiple of 4."
   Do While iLen > 0
      If iBuf(iLen - 1) <> Asc("=") Then Exit Do
      iLen = iLen - 1
      Loop
   Dim OLen As Long: OLen = (iLen * 3) \ 4
   Dim Out() As Byte
   ReDim Out(0 To OLen - 1) As Byte
   Dim ip As Long
   Dim op As Long
   Do While ip < iLen
      Dim i0 As Byte: i0 = iBuf(ip): ip = ip + 1
      Dim i1 As Byte: i1 = iBuf(ip): ip = ip + 1
      Dim i2 As Byte: If ip < iLen Then i2 = iBuf(ip): ip = ip + 1 Else i2 = Asc("A")
      Dim i3 As Byte: If ip < iLen Then i3 = iBuf(ip): ip = ip + 1 Else i3 = Asc("A")
      If i0 > 127 Or i1 > 127 Or i2 > 127 Or i3 > 127 Then _
         err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
      Dim b0 As Byte: b0 = Map2(i0)
      Dim b1 As Byte: b1 = Map2(i1)
      Dim b2 As Byte: b2 = Map2(i2)
      Dim b3 As Byte: b3 = Map2(i3)
      If b0 > 63 Or b1 > 63 Or b2 > 63 Or b3 > 63 Then _
         err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
      Dim o0 As Byte: o0 = (b0 * 4) Or (b1 \ &H10)
      Dim o1 As Byte: o1 = ((b1 And &HF) * &H10) Or (b2 \ 4)
      Dim o2 As Byte: o2 = ((b2 And 3) * &H40) Or b3
      Out(op) = o0: op = op + 1
      If op < OLen Then Out(op) = o1: op = op + 1
      If op < OLen Then Out(op) = o2: op = op + 1
      Loop
   Base64Decode = Out
   End Function

Private Sub Init()
   Dim c As Integer, i As Integer
   ' set Map1
   i = 0
   For c = Asc("A") To Asc("Z"): Map1(i) = c: i = i + 1: Next
   For c = Asc("a") To Asc("z"): Map1(i) = c: i = i + 1: Next
   For c = Asc("0") To Asc("9"): Map1(i) = c: i = i + 1: Next
   Map1(i) = Asc("+"): i = i + 1
   Map1(i) = Asc("/"): i = i + 1
   ' set Map2
   For i = 0 To 127: Map2(i) = 255: Next
   For i = 0 To 63: Map2(Map1(i)) = i: Next
   InitDone = True
   End Sub

Private Function ConvertStringToBytes(ByVal s As String) As Byte()
   Dim b1() As Byte: b1 = s
   Dim l As Long: l = (UBound(b1) + 1) \ 2
   If l = 0 Then ConvertStringToBytes = b1: Exit Function
   Dim b2() As Byte
   ReDim b2(0 To l - 1) As Byte
   Dim p As Long
   For p = 0 To l - 1
      Dim c As Long: c = b1(2 * p) + 256 * CLng(b1(2 * p + 1))
      If c >= 256 Then c = Asc("?")
      b2(p) = c
      Next
   ConvertStringToBytes = b2
   End Function

Private Function ConvertBytesToString(b() As Byte) As String
   Dim l As Long: l = UBound(b) - LBound(b) + 1
   Dim b2() As Byte
   ReDim b2(0 To (2 * l) - 1) As Byte
   Dim p0 As Long: p0 = LBound(b)
   Dim p As Long
   For p = 0 To l - 1: b2(2 * p) = b(p0 + p): Next
   Dim s As String: s = b2
   ConvertBytesToString = s
   End Function

Function UTF8_Decode(ByVal sStr As String)
    Dim l As Long, sUTF8 As String, iChar As Integer, iChar2 As Integer
    For l = 1 To Len(sStr)
        iChar = Asc(Mid(sStr, l, 1))
        If iChar > 127 Then
            If Not iChar And 32 Then ' 2 chars
            iChar2 = Asc(Mid(sStr, l + 1, 1))
            sUTF8 = sUTF8 & ChrW$(((31 And iChar) * 64 + (63 And iChar2)))
            l = l + 1
        Else
            Dim iChar3 As Integer
            iChar2 = Asc(Mid(sStr, l + 1, 1))
            iChar3 = Asc(Mid(sStr, l + 2, 1))
            sUTF8 = sUTF8 & ChrW$(((iChar And 15) * 16 * 256) + ((iChar2 And 63) * 64) + (iChar3 And 63))
            l = l + 2
        End If
            Else
            sUTF8 = sUTF8 & Chr$(iChar)
        End If
    Next l
    UTF8_Decode = sUTF8
End Function

Select allOpen in new window