Получение MD5 хэша в VBA

Перевод и кодировка

Во вложенном файле представлен вариант функции для получения MD5 хэша строки без использования .Net Framework
(чистый VBA, то есть будет работать на любом компьютере)

Добавьте в файл стандартный модуль, и поместите туда следующий код:

'---------------------------------------------------------------------------------------
' © 2024 ExcelVBA.ru   вычисление MD5 хеша строки
'---------------------------------------------------------------------------------------
Option Explicit: Option Compare Text: Option Private Module
Private Const BITS_TO_A_BYTE = 8, BYTES_TO_A_WORD = 4, BITS_TO_A_WORD = 32: Private m_lOnBits(30), m_l2Power(30)
 
Public Function MD5(txt) ' основная функция
    On Error Resume Next:  MD5init: txt = StrConv(Str2ByteArr(txt), vbUnicode)
    MD5 = CalcMD5(txt)
End Function
 
Private Sub MD5init()
    Dim i&: For i = 0 To 30: m_lOnBits(i) = (2 ^ (i + 1)) - 1: m_l2Power(i) = 2 ^ (i): Next i
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
        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
        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 Function
 
Private Function RotateLeft(lValue, iShiftBits)
    RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
 
Private Function AddUnsigned(lX, lY)
    Dim lX4, lY4, lX8, lY8, 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
    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, lNumberOfWords, lWordArray(), lBytePosition, lByteCount, lWordCount
    Const MODULUS_BITS = 512, 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, 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
 
Private Function CalcMD5(sMessage)
    Dim x, k, AA, BB, CC, DD, a, b, c, d
    Const S11 = 7, S12 = 12, S13 = 17, S14 = 22, S21 = 5, S22 = 9, S23 = 14, S24 = 20, S31 = 4, S32 = 11, S33 = 16, S34 = 23, S41 = 6, S42 = 10, S43 = 15, 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
    CalcMD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
End Function
 
Private Function Str2ByteArr(txt) As Byte()
    On Error Resume Next
    With CreateObject("ADODB.Stream")
        .Type = 2: .Mode = 3: .Charset = "utf-8": .Open:  .WriteText txt
        .Type = 1: .flush: .Position = 0: .Type = 1: .Read 3: Str2ByteArr = .Read(): .Close
    End With
End Function

Sub Пример_Вычисления_MD5_HASH_для_строки()
    txt = "текстовая строка"
    res = MD5(txt)
    msgbox res
End Sub

Другой вариант получения MD5 хеша в VBA - вызов функций .NET Framework
В этом варианте кода значительно меньше.
В большинстве случаев .NET Framework установлен в системе, так что проблем быть не должно (но я делаю надстройки, которые работают на тысячах разных компов, и мне попадались случаи, когда эти функции не работали, потому я отказался от их использования, перейдя на чистый VBA)

Function GetHash(ByVal txt$) As String
    Dim oUTF8, oMD5, abyt, i&, k&, hi&, lo&, chHi$, chLo$
    Set oUTF8 = CreateObject("System.Text.UTF8Encoding")
    Set oMD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    abyt = oMD5.ComputeHash_2(oUTF8.GetBytes_4(txt$))
    For i = 1 To LenB(abyt)
        k = AscB(MidB(abyt, i, 1))
        lo = k Mod 16: hi = (k - lo) / 16
        If hi > 9 Then chHi = Chr(Asc("a") + hi - 10) Else chHi = Chr(Asc("0") + hi)
        If lo > 9 Then chLo = Chr(Asc("a") + lo - 10) Else chLo = Chr(Asc("0") + lo)
        GetHash = GetHash & chHi & chLo
    Next
    Set oUTF8 = Nothing: Set oMD5 = Nothing
End Function

Sub Получение_MD5_HASH()
    txt = "текстовая строка"
    res = GetHash(txt)
    Debug.Print res
End Sub

Ещё один вариант этой функции, - для получения хеша файла:

Function GetFileHash(ByVal path As String) As String
    On Error Resume Next
    Dim oUTF8, oMD5, abyt, i&, k&, hi&, lo&, chHi$, chLo$, GetBytes() As Byte, cnt&
    With CreateObject("Adodb.Stream")
        .Type = 1 ' adTypeBinary
        .Open
        .LoadFromFile path
        .Position = 0
        GetBytes = .Read
        .Close
    End With
 
    cnt& = 0: cnt& = UBound(GetBytes)
    If cnt& = 0 Then Exit Function
 
    Set oMD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    abyt = oMD5.ComputeHash_2(GetBytes)
 
    For i = 1 To LenB(abyt)
        k = AscB(MidB(abyt, i, 1))
        lo = k Mod 16: hi = (k - lo) / 16
        If hi > 9 Then chHi = Chr(Asc("a") + hi - 10) Else chHi = Chr(Asc("0") + hi)
        If lo > 9 Then chLo = Chr(Asc("a") + lo - 10) Else chLo = Chr(Asc("0") + lo)
        GetFileHash = GetFileHash & chHi & chLo
    Next
    Set oUTF8 = Nothing: Set oMD5 = Nothing
End Function

Повторюсь, лучше применять вариант на чистом VBA (во вложении)
В прикреплённом файле также показано, что можно использовать VBA функцию как формулу =MD5() на листе Excel

Вложения:

MD5_VBA_new_version.xls

83 КБ

28508 просмотров

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Олег, 21 Сен 2022 - 22:52.#1

Помог вариант без использования NET Framework. Почему-то вариант с Framework работает только со старыми версиями, а с 4.5 и 4.8 выдает ошибку.

Гость, 21 Дек 2020 - 16:37.#2

Спасибо Вам, добрый человек! Очень помог вариант через API. Работает как надо.

imort, 27 Мар 2019 - 20:34.#3

Константин, проверьте значение хеша "текстовая строка":812c4f7fb1ccc1aebe7802dced6c4d67
https://www.liveinternet.ru/community/rss_sql_ru_access_programming/post...

Константин, 26 Окт 2017 - 17:42.#4

Нашел решение на другом форуме через API

Option Explicit
 
Private Type MD5_CTX
  i(1 To 2)         As Long
  buf(1 To 4)       As Long
  inp(1 To 64)      As Byte
  digest(1 To 16)   As Byte
End Type
 
Private Declare Sub MD5Init Lib "cryptdll.dll" (Context As MD5_CTX)
Private Declare Sub MD5Update Lib "cryptdll.dll" (Context As MD5_CTX, ByVal strInput As String, ByVal lLen As Long)
Private Declare Sub MD5Final Lib "cryptdll.dll" (Context As MD5_CTX)
 
Public Function DigestFileToHexStr(strFilename As String) As String
    On Error GoTo ErrorHandler
 
    Dim strBuffer   As String
    Dim myContext   As MD5_CTX
    Dim result      As String
    Dim lp          As Long
    Dim MD5         As String
    Dim ff          As Integer
 
    ff = FreeFile()
    Open strFilename For Binary As #ff
    strBuffer = String$(LOF(ff), vbNullChar)
    Get #ff, 1&, strBuffer
    Close #ff: ff = 0
 
    MD5Init myContext
    If 0 = Err.LastDllError Then
        MD5Update myContext, strBuffer, Len(strBuffer)
        If 0 = Err.LastDllError Then
            MD5Final myContext
            If 0 <> Err.LastDllError Then Err.Raise 51
        Else
            Err.Raise 51
        End If
    Else
        Err.Raise 51
    End If
 
    result = StrConv(myContext.digest, vbUnicode)
 
    For lp = 1& To Len(result)
        DigestFileToHexStr = DigestFileToHexStr & Right$("00" & Hex(Asc(Mid(result, lp, 1&))), 2&)
    Next
 
    Exit Function
ErrorHandler:
    Debug.Print "#" & Err.Number & ". " & Err.Description & ". LastDllErr = " & Err.LastDllError
End Function
 
Private Sub Form_Load()
    Debug.Print DigestFileToHexStr("C:\Users\Alex\Desktop\1.txt")
End Sub

Игорь (администратор сайта), 27 Мар 2017 - 18:46.#5

Считывается содержимое произвольного файла (в бинарном виде)
Так что код будет одинаковый для любого файла

Гость, 27 Мар 2017 - 11:13.#6

Игорь, здравствуйте!

Ваш ответ, на сколько я понял, позволяет получить хэш-сумму содержимого, а не файла. Это же разные вещи. Или это не так?
И также получить хэш-сумму фотографии или PDF документа в таком случае не получится, поскольку эти типы документов как правило формируются без считываемого текста.

Спасибо.

Игорь (администратор сайта), 27 Мар 2017 - 03:16.#7

Сначала надо считать текст из файла в переменную, потом вычислить MD5 для содержимого этой переменной (содержимого файла),
потом преобразовать полученную строку в числовое значение, и убрать знак минус (-), если он есть
Вот как-то так. Готового кода у меня нет.

Гость, 27 Мар 2017 - 02:52.#8

Добрый день!
А как получить хэш-сумму файла, а не текста?

Спасибо.

Получение MD5 хэша в VBA

Комментарии

Настройки просмотра комментариев

Отправить комментарий

НАДСТРОЙКИ ДЛЯ EXCEL