Excel VBAのパスワードハッシュ関数

Question

SHA-1などの標準アルゴリズムを使用してパスワードをハッシュするExcel VBAで記述された関数が必要です。次のようなシンプルなインターフェースを備えたもの：

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

この関数は、Excel 2003がインストールされたXPワークステーションで動作する必要がありますが、サードパーティのコンポーネントを使用する必要はありません。

このハッシュ機能を実現するためのサンプルを知っている人はいますか？

Answer 1

以下は、Excelの数式に使用できるSHA1ハッシュを計算するためのモジュールです。 '= SHA1HASH（ "test"）'。それを使用するには、「module_sha1」という新しいモジュールを作成し、すべてをコピーして貼り付けます。これは、 http://vb.wikia.com/wiki/SHAのVBAコードに基づいています。 -1.bas 、文字列の受け渡しをサポートするための変更、および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 2

最近では、VBAの.NETライブラリを活用できます。以下はExcel 2016で機能します。ハッシュを大文字の16進数として返します。

Public Function SHA1(ByVal s As String) As String
    Dim Enc As Object, Prov As Object
    Dim Hash() As Byte, i As Integer

    Set Enc = CreateObject("System.Text.UTF8Encoding")
    Set Prov = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")

    Hash = Prov.ComputeHash_2(Enc.GetBytes_4(s))

    SHA1 = ""
    For i = LBound(Hash) To UBound(Hash)
        SHA1 = SHA1 & Hex(Hash(i) \ 16) & Hex(Hash(i) Mod 16)
    Next
End Function

Answer 3

「module_md5」という名前のExcelモジュールに挿入された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