0

I've found posts about hash functions but couldn't get to use them because of errors. I haven't done VBA since 2010 so it's a bit far and I can't debug it.

The following post provide with a hash function : Is there an Excel function to create a hash value? .

Public Function BASE64SHA1(ByVal sTextToHash As String)

    Dim asc As Object
    Dim enc As Object
    Dim TextToHash() As Byte
    Dim SharedSecretKey() As Byte
    Dim bytes() As Byte
    Const cutoff As Integer = 5

    Set asc = CreateObject("System.Text.UTF8Encoding")
    Set enc = CreateObject("System.Security.Cryptography.HMACSHA1")

    TextToHash = asc.GetBytes_4(sTextToHash)
    SharedSecretKey = asc.GetBytes_4(sTextToHash)
    enc.Key = SharedSecretKey

    bytes = enc.ComputeHash_2((TextToHash))
    BASE64SHA1 = EncodeBase64(bytes)
    BASE64SHA1 = Left(BASE64SHA1, cutoff)

    Set asc = Nothing
    Set enc = Nothing

End Function

Private Function EncodeBase64(ByRef arrData() As Byte) As String

    Dim objXML As Object
    Dim objNode As Object

    Set objXML = CreateObject("MSXML2.DOMDocument")
    Set objNode = objXML.createElement("b64")

    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.text

    Set objNode = Nothing
    Set objXML = Nothing

End Function

When trying to use it from a cell, I get #VALUE!

When trying to debug, I get that this line is the source of the problem without further information :

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

The final purpose is to anonymize emails before sending the worksheet.

2
  • What References do you have checked ? Jun 29, 2017 at 13:42
  • Visual Basic For Application, Microsoft Excel 16.0 Object Library, OLE Automation, Microsoft Office 16.0 Object Library
    – Adrien H
    Jun 29, 2017 at 14:09

1 Answer 1

1

I've found the following function which works with excel 2016. It only uses VBA, so it doesn't use broken dependencies like the others. I would have preferred something faster (it takes about 20-25 minutes for hashing about 600 000 emails) but I'm fine with this for the moment.

Private Type FourBytes
    a As Byte
    b As Byte
    c As Byte
    d As Byte
End Type
Private Type OneLong
    l As Long
End Type

Function HexDefaultSHA1(Message() As Byte) As String
 Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long
 DefaultSHA1 Message, H1, H2, H3, H4, H5
 HexDefaultSHA1 = DecToHex5(H1, H2, H3, H4, H5)
End Function

Function HexSHA1(Message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long) As String
 Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long
 xSHA1 Message, Key1, Key2, Key3, Key4, H1, H2, H3, H4, H5
 HexSHA1 = DecToHex5(H1, H2, H3, H4, H5)
End Function

Sub DefaultSHA1(Message() As Byte, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long)
 xSHA1 Message, &H5A827999, &H6ED9EBA1, &H8F1BBCDC, &HCA62C1D6, H1, H2, H3, H4, H5
End Sub

Sub xSHA1(Message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long)

 Dim U As Long, P As Long
 Dim FB As FourBytes, OL As OneLong
 Dim i As Integer
 Dim w(80) As Long
 Dim a As Long, b As Long, c As Long, d As Long, E As Long
 Dim t As Long

 H1 = &H67452301: H2 = &HEFCDAB89: H3 = &H98BADCFE: H4 = &H10325476: H5 = &HC3D2E1F0

 U = UBound(Message) + 1: OL.l = U32ShiftLeft3(U): a = U \ &H20000000: LSet FB = OL 'U32ShiftRight29(U)

 ReDim Preserve Message(0 To (U + 8 And -64) + 63)
 Message(U) = 128

 U = UBound(Message)
 Message(U - 4) = a
 Message(U - 3) = FB.d
 Message(U - 2) = FB.c
 Message(U - 1) = FB.b
 Message(U) = FB.a

 While P < U
     For i = 0 To 15
         FB.d = Message(P)
         FB.c = Message(P + 1)
         FB.b = Message(P + 2)
         FB.a = Message(P + 3)
         LSet OL = FB
         w(i) = OL.l
         P = P + 4
     Next i

     For i = 16 To 79
         w(i) = U32RotateLeft1(w(i - 3) Xor w(i - 8) Xor w(i - 14) Xor w(i - 16))
     Next i

     a = H1: b = H2: c = H3: d = H4: E = H5

     For i = 0 To 19
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), E), w(i)), Key1), ((b And c) Or ((Not b) And d)))
         E = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     For i = 20 To 39
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), E), w(i)), Key2), (b Xor c Xor d))
         E = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     For i = 40 To 59
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), E), w(i)), Key3), ((b And c) Or (b And d) Or (c And d)))
         E = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     For i = 60 To 79
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), E), w(i)), Key4), (b Xor c Xor d))
         E = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i

     H1 = U32Add(H1, a): H2 = U32Add(H2, b): H3 = U32Add(H3, c): H4 = U32Add(H4, d): H5 = U32Add(H5, E)
 Wend
End Sub

Function U32Add(ByVal a As Long, ByVal b As Long) As Long
 If (a Xor b) < 0 Then
     U32Add = a + b
 Else
     U32Add = (a Xor &H80000000) + b Xor &H80000000
 End If
End Function

Function U32ShiftLeft3(ByVal a As Long) As Long
 U32ShiftLeft3 = (a And &HFFFFFFF) * 8
 If a And &H10000000 Then U32ShiftLeft3 = U32ShiftLeft3 Or &H80000000
End Function

Function U32ShiftRight29(ByVal a As Long) As Long
 U32ShiftRight29 = (a And &HE0000000) \ &H20000000 And 7
End Function

Function U32RotateLeft1(ByVal a As Long) As Long
 U32RotateLeft1 = (a And &H3FFFFFFF) * 2
 If a And &H40000000 Then U32RotateLeft1 = U32RotateLeft1 Or &H80000000
 If a And &H80000000 Then U32RotateLeft1 = U32RotateLeft1 Or 1
End Function
Function U32RotateLeft5(ByVal a As Long) As Long
 U32RotateLeft5 = (a And &H3FFFFFF) * 32 Or (a And &HF8000000) \ &H8000000 And 31
 If a And &H4000000 Then U32RotateLeft5 = U32RotateLeft5 Or &H80000000
End Function
Function U32RotateLeft30(ByVal a As Long) As Long
 U32RotateLeft30 = (a And 1) * &H40000000 Or (a And &HFFFC) \ 4 And &H3FFFFFFF
 If a And 2 Then U32RotateLeft30 = U32RotateLeft30 Or &H80000000
End Function

Function DecToHex5(ByVal H1 As Long, ByVal H2 As Long, ByVal H3 As Long, ByVal H4 As Long, ByVal H5 As Long) As String
 Dim H As String, l As Long
 DecToHex5 = "00000000 00000000 00000000 00000000 00000000"
 H = Hex(H1): l = Len(H): Mid(DecToHex5, 9 - l, l) = H
 H = Hex(H2): l = Len(H): Mid(DecToHex5, 18 - l, l) = H
 H = Hex(H3): l = Len(H): Mid(DecToHex5, 27 - l, l) = H
 H = Hex(H4): l = Len(H): Mid(DecToHex5, 36 - l, l) = H
 H = Hex(H5): l = Len(H): Mid(DecToHex5, 45 - l, l) = H
End Function

Public Function SHA1Trunc(str)
  Dim i As Integer
  Dim arr() As Byte
  ReDim arr(0 To Len(str) - 1) As Byte
  Const cutoff As Integer = 40

  For i = 0 To Len(str) - 1
   arr(i) = Asc(Mid(str, i + 1, 1))
  Next i

  SHA1Trunc = Replace(LCase(HexDefaultSHA1(arr)), " ", "")
  SHA1Trunc = Left(SHA1Trunc, cutoff)

End Function

Sources :

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .