Función de hash de contraseña para Excel VBA

Question

Necesito una función escrita en Excel VBA que codifique contraseñas utilizando un algoritmo estándar como SHA-1. Algo con una interfaz sencilla como:

Public Function CreateHash(Value As String) As String 
... 
End Function 

La función tiene que trabajar en una estación de trabajo XP con Excel 2003 instalado, pero por lo demás debe utilizar ningún componente de terceros. Puede hacer referencia y usar DLL que están disponibles con XP, como CryptoAPI.

¿Alguien sabe de una muestra para lograr esta funcionalidad de hash?

Answer 1

Encontrará una implementación de MD5 y SHA256 para VB y VBScript here.

Creo que sería bastante fácil de exportar a puerto.

Sin embargo, alguien ya lo ha hecho. Lamentablemente, la solución está en el intercambio de expertos que no permite enlaces directos. Entonces tenemos que pasar por Google. Haga clic en here para realizar una búsqueda en Google y luego haga clic en el primer resultado. Desplácese hacia abajo para ver la solución aceptada.

Answer 2

Aquí hay un módulo para calcular los valores hash SHA1 que se puede utilizar para fórmulas de Excel, por ejemplo. '= SHA1HASH ("prueba")'. Para usarlo, cree un nuevo módulo llamado 'module_sha1' y cópielo y péguelo todo. Esto se basa en algún código VBA de http://vb.wikia.com/wiki/SHA-1.bas, con cambios para admitir el paso de una cadena y ejecutable a partir de fórmulas en celdas de Excel.

' Based on: http://vb.wikia.com/wiki/SHA-1.bas 
Option Explicit 

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) 
'CA62C1D68F1BBCDC6ED9EBA15A827999 + "abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D" 
'"abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D" 

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 

' Convert the string into bytes so we can use the above functions 
' From Chris Hulbert: http://splinter.com.au/blog 

Public Function SHA1HASH(str) 
    Dim i As Integer 
    Dim arr() As Byte 
    ReDim arr(0 To Len(str) - 1) As Byte 
    For i = 0 To Len(str) - 1 
    arr(i) = Asc(Mid(str, i + 1, 1)) 
    Next i 
    SHA1HASH = Replace(LCase(HexDefaultSHA1(arr)), " ", "") 
End Function 

Answer 3

Este es el código MD5 insertado en un módulo de Excel con el nombre de "module_md5":

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

    Private m_lOnBits(30) 
    Private m_l2Power(30) 

    Sub SetUpArrays() 
     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) 
    End Sub 

    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 RotateLeft(lValue, iShiftBits) 
     RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits)) 
    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 F(x, y, z) 
     F = (x And y) Or ((Not x) And z) 
    End Function 

    Private Function G(x, y, z) 
     G = (x And z) Or (y And (Not z)) 
    End Function 

    Private Function H(x, y, z) 
     H = (x Xor y Xor z) 
    End Function 

    Private Function I(x, y, z) 
     I = (y Xor (x Or (Not z))) 
    End Function 

    Private Sub FF(a, b, c, d, x, s, ac) 
     a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(b, c, d), x), ac)) 
     a = RotateLeft(a, s) 
     a = AddUnsigned(a, b) 
    End Sub 

    Private Sub GG(a, b, c, d, x, s, ac) 
     a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(b, c, d), x), ac)) 
     a = RotateLeft(a, s) 
     a = AddUnsigned(a, b) 
    End Sub 

    Private Sub HH(a, b, c, d, x, s, ac) 
     a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(b, c, d), x), ac)) 
     a = RotateLeft(a, s) 
     a = AddUnsigned(a, b) 
    End Sub 

    Private Sub II(a, b, c, d, x, s, ac) 
     a = AddUnsigned(a, AddUnsigned(AddUnsigned(I(b, c, d), x), ac)) 
     a = RotateLeft(a, s) 
     a = AddUnsigned(a, b) 
    End Sub 

    Private Function ConvertToWordArray(sMessage) 
     Dim lMessageLength 
     Dim lNumberOfWords 
     Dim lWordArray() 
     Dim lBytePosition 
     Dim lByteCount 
     Dim lWordCount 

     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 = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE 
      lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition) 
      lByteCount = lByteCount + 1 
     Loop 

     lWordCount = lByteCount \ BYTES_TO_A_WORD 
     lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE 

     lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition) 

     lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3) 
     lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29) 

     ConvertToWordArray = lWordArray 
    End Function 

    Private Function WordToHex(lValue) 
     Dim lByte 
     Dim lCount 

     For lCount = 0 To 3 
      lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1) 
      WordToHex = WordToHex & Right("0" & Hex(lByte), 2) 
     Next 
    End Function 

    Public Function MD5(sMessage) 

     module_md5.SetUpArrays 

     Dim x 
     Dim k 
     Dim AA 
     Dim BB 
     Dim CC 
     Dim DD 
     Dim a 
     Dim b 
     Dim c 
     Dim d 

     Const S11 = 7 
     Const S12 = 12 
     Const S13 = 17 
     Const S14 = 22 
     Const S21 = 5 
     Const S22 = 9 
     Const S23 = 14 
     Const S24 = 20 
     Const S31 = 4 
     Const S32 = 11 
     Const S33 = 16 
     Const S34 = 23 
     Const S41 = 6 
     Const S42 = 10 
     Const S43 = 15 
     Const S44 = 21 

     x = ConvertToWordArray(sMessage) 

     a = &H67452301 
     b = &HEFCDAB89 
     c = &H98BADCFE 
     d = &H10325476 

     For k = 0 To UBound(x) Step 16 
      AA = a 
      BB = b 
      CC = c 
      DD = d 

      FF a, b, c, d, x(k + 0), S11, &HD76AA478 
      FF d, a, b, c, x(k + 1), S12, &HE8C7B756 
      FF c, d, a, b, x(k + 2), S13, &H242070DB 
      FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE 
      FF a, b, c, d, x(k + 4), S11, &HF57C0FAF 
      FF d, a, b, c, x(k + 5), S12, &H4787C62A 
      FF c, d, a, b, x(k + 6), S13, &HA8304613 
      FF b, c, d, a, x(k + 7), S14, &HFD469501 
      FF a, b, c, d, x(k + 8), S11, &H698098D8 
      FF d, a, b, c, x(k + 9), S12, &H8B44F7AF 
      FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1 
      FF b, c, d, a, x(k + 11), S14, &H895CD7BE 
      FF a, b, c, d, x(k + 12), S11, &H6B901122 
      FF d, a, b, c, x(k + 13), S12, &HFD987193 
      FF c, d, a, b, x(k + 14), S13, &HA679438E 
      FF b, c, d, a, x(k + 15), S14, &H49B40821 

      GG a, b, c, d, x(k + 1), S21, &HF61E2562 
      GG d, a, b, c, x(k + 6), S22, &HC040B340 
      GG c, d, a, b, x(k + 11), S23, &H265E5A51 
      GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA 
      GG a, b, c, d, x(k + 5), S21, &HD62F105D 
      GG d, a, b, c, x(k + 10), S22, &H2441453 
      GG c, d, a, b, x(k + 15), S23, &HD8A1E681 
      GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8 
      GG a, b, c, d, x(k + 9), S21, &H21E1CDE6 
      GG d, a, b, c, x(k + 14), S22, &HC33707D6 
      GG c, d, a, b, x(k + 3), S23, &HF4D50D87 
      GG b, c, d, a, x(k + 8), S24, &H455A14ED 
      GG a, b, c, d, x(k + 13), S21, &HA9E3E905 
      GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8 
      GG c, d, a, b, x(k + 7), S23, &H676F02D9 
      GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A 

      HH a, b, c, d, x(k + 5), S31, &HFFFA3942 
      HH d, a, b, c, x(k + 8), S32, &H8771F681 
      HH c, d, a, b, x(k + 11), S33, &H6D9D6122 
      HH b, c, d, a, x(k + 14), S34, &HFDE5380C 
      HH a, b, c, d, x(k + 1), S31, &HA4BEEA44 
      HH d, a, b, c, x(k + 4), S32, &H4BDECFA9 
      HH c, d, a, b, x(k + 7), S33, &HF6BB4B60 
      HH b, c, d, a, x(k + 10), S34, &HBEBFBC70 
      HH a, b, c, d, x(k + 13), S31, &H289B7EC6 
      HH d, a, b, c, x(k + 0), S32, &HEAA127FA 
      HH c, d, a, b, x(k + 3), S33, &HD4EF3085 
      HH b, c, d, a, x(k + 6), S34, &H4881D05 
      HH a, b, c, d, x(k + 9), S31, &HD9D4D039 
      HH d, a, b, c, x(k + 12), S32, &HE6DB99E5 
      HH c, d, a, b, x(k + 15), S33, &H1FA27CF8 
      HH b, c, d, a, x(k + 2), S34, &HC4AC5665 

      II a, b, c, d, x(k + 0), S41, &HF4292244 
      II d, a, b, c, x(k + 7), S42, &H432AFF97 
      II c, d, a, b, x(k + 14), S43, &HAB9423A7 
      II b, c, d, a, x(k + 5), S44, &HFC93A039 
      II a, b, c, d, x(k + 12), S41, &H655B59C3 
      II d, a, b, c, x(k + 3), S42, &H8F0CCC92 
      II c, d, a, b, x(k + 10), S43, &HFFEFF47D 
      II b, c, d, a, x(k + 1), S44, &H85845DD1 
      II a, b, c, d, x(k + 8), S41, &H6FA87E4F 
      II d, a, b, c, x(k + 15), S42, &HFE2CE6E0 
      II c, d, a, b, x(k + 6), S43, &HA3014314 
      II b, c, d, a, x(k + 13), S44, &H4E0811A1 
      II a, b, c, d, x(k + 4), S41, &HF7537E82 
      II d, a, b, c, x(k + 11), S42, &HBD3AF235 
      II c, d, a, b, x(k + 2), S43, &H2AD7D2BB 
      II b, c, d, a, x(k + 9), S44, &HEB86D391 

      a = AddUnsigned(a, AA) 
      b = AddUnsigned(b, BB) 
      c = AddUnsigned(c, CC) 
      d = AddUnsigned(d, DD) 
     Next 

     MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d)) 
    End Function