Получение MD5 хэша в 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

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

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

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

Вложения:

MD5_VBA.xls

52 КБ

25700 просмотров

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

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

Олег, 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