Deklarationen
Private Declare Function CryptAcquireContext Lib "advapi32.dll" _
Alias "CryptAcquireContextA" (ByRef phProv As Long, _
ByVal pszContainer As String, _
ByVal pszProvider As String, _
ByVal dwProvType As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" _
(ByVal hProv As Long, _
ByVal Algid As Long, _
ByVal hSessionKey As Long, _
ByVal dwFlags As Long, _
ByRef phHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" ( _
ByVal hHash As Long, _
ByVal pbData As String, _
ByVal dwDataLen As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" ( _
ByVal hHash As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32.dll" ( _
ByVal hSessionKey As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" ( _
ByVal hProv As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" ( _
ByVal hHash As Long, _
ByVal dwParam As Long, _
ByVal pbData As String, _
ByRef pdwDataLen As Long, _
ByVal dwFlags As Long) As Long
Private Const PROV_RSA_FULL As Long = 1
Private Const CRYPT_VERIFYCONTEXT As Long = 0
Private Const CRYPT_NEWKEYSET As Long = 8
Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
Private Const ALG_CLASS_HASH As Long = 32768
Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_TYPE_STREAM As Long = 2048
Private Const ALG_SID_MD5 As Long = 3
Private Const CALG_MD5 As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
Private Const HP_HASHVAL As Long = 2
Lokale Variablen
Private Const BuffLen As Long = 1024
Dim hCryptProv As Long
Dim strHash As String
Dim hSessionKey As Long
Dim hHash As Long
Class_Initialize und Class_Terminate
Private Sub Class_Initialize()
Dim lngReturnValue As Long
' Handle erstellen
lngReturnValue = CryptAcquireContext(hCryptProv, vbNullString, vbNullString, _
PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)
' NTE_BAD_KEYSET -2146893802 &H80090016 Keyset does not exist
If lngReturnValue = 0 And Err.LastDllError = &H80090016 Then
' There's no default keyset container!!!
' Get the provider context and create
' a default keyset container
lngReturnValue = CryptAcquireContext(hCryptProv, vbNullString, _
vbNullString, PROV_RSA_FULL, CRYPT_NEWKEYSET)
End If
' Err.Raise Err.LastDllError, , "DLL gab Fehler zurück. Fehler." & _
vbCrLf & "Fehler beim Erstellen des Handles"
End Sub
Private Sub Class_Terminate()
If hSessionKey <> 0 Then
CryptDestroyKey hSessionKey ' Key der Session zerstören
End If
If hCryptProv <> 0 Then
CryptReleaseContext hCryptProv, 0
End If
End Sub
MD5-Funktionen
Private Function MD5_Init()
Dim lngReturnValue As Long
'Hash erstellen
lngReturnValue = CryptCreateHash(hCryptProv, CALG_MD5, 0, 0, hHash)
If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
"DLL gab Error aus. Hash-Objekt kann nicht erstellt werden! " & _
"(CryptCreateHash API)"
End Function
Private Function MD5_Update(ByVal Key As String)
Dim lngReturnValue As Long
'Key in den Hash schreiben
lngReturnValue = CryptHashData(hHash, Key, Len(Key), 0)
If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
"DLL-Fehler: Daten konnten nicht in den Hash geschrieben werden " & _
"(CryptHashData API)"
End Function
Private Function MD5_Finalize()
Dim lngReturnValue As Long
Dim lngHashLen As Long
'Länge des Hash ermitteln
lngReturnValue = CryptGetHashParam(hHash, HP_HASHVAL, vbNull, lngHashLen, 0)
'String auf ermittelte Länge setzen
strHash = String(lngHashLen + 1, vbNullChar)
'Key auslesen
lngReturnValue = CryptGetHashParam(hHash, HP_HASHVAL, strHash, lngHashLen, 0)
If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
"DLL gab Fehler aus. Hash-Value ungültig!"
If hSessionKey <> 0 Then CryptDestroyKey hSessionKey
If hHash <> 0 Then CryptDestroyHash hHash
End Function
Str2Hex-Funktion
Private Function Str2Hex(text As String, Optional separator As String = "") _
As String
Dim val As String
Do While Len(text) > 0
val = Hex(Asc(Left(text, 1)))
val = IIf(Len(val) = 1, "0" & val, val)
Str2Hex = Str2Hex & val & separator
text = Mid(text, 2)
Loop
If Len(Str2Hex) > 0 Then Str2Hex = Left(Str2Hex, Len(Str2Hex) - Len(separator))
End Function
DigestFileToHexStr-Funktion
Public Function DigestFileToHexStr(FileName As String) As String
Dim ByteBuffer As String
Dim iLoc As Long
Dim iLof As Long
Dim iDiff As Long
'#######################
' Bard
Dim DateiNR As Integer
DateiNR = FreeFile
' /Bard
'#######################
On Error GoTo errDatOpen
Open FileName For Binary Access Read As DateiNR
On Error GoTo 0
iLof = LOF(DateiNR)
iLoc = 0
MD5_Init
Do While iLoc < iLof
iLoc = Loc(DateiNR)
iDiff = iLof - iLoc
If iDiff >= BuffLen Then
ByteBuffer = String(BuffLen, " ")
Else
ByteBuffer = String(iDiff, " ")
End If
Get DateiNR, , ByteBuffer
MD5_Update ByteBuffer
Loop
Close DateiNR
MD5_Finalize
DigestFileToHexStr = Str2Hex(Left(strHash, 16))
Exit Function
errDatOpen:
DigestFileToHexStr = ""
End Function
Beispiel:
http://www.activevb.de/cgi-bin/forenarchive/forenarchive.pl?a=0&b=b&d=94102&e=1