Hash par Archivos:
En un Modulo:
'---------------------------------------------------------------------------------------
' Module : mFileHash
' DateTime : 21/05/2008 06:01
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://www.advancevb.com.ar
' Purpose : API file hash
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' Reference : http://www.mvps.org/emorcillo/en/code/vb6/index.shtml
'
' History : 21/05/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit
Private Const BLOCK_SIZE As Long = 32 * 1024& ' 32K
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const GENERIC_READ As Long = &H80000000
Private Const INVALID_HANDLE_VALUE As Long = (-1)
Private Const OPEN_EXISTING As Long = 3
Private Const PROV_RSA_FULL As Long = 1
Private Const ALG_CLASS_HASH As Long = 32768
Private Const ALG_TYPE_ANY As Long = 0
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
Private Const ALG_SID_MD2 As Long = 1
Private Const ALG_SID_MD4 As Long = 2
Private Const ALG_SID_MD5 As Long = 3
Private Const ALG_SID_SHA1 As Long = 4
Private Const HP_HASHVAL As Long = 2
Private Const HP_HASHSIZE As Long = 4
Public Enum HashAlgorithm
MD2 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2
MD4 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4
md5 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5
SHA1 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA1
End Enum
Private Type tFileChunks
bvChunck() As Byte
lChuncks As Long
bvReminder() As Byte
lReminder As Long
lCount As Long
End Type
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
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 CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, ByRef phHash As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, pbData As Byte, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" (ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Public Function HashFile(ByVal sFile As String, ByVal eHash As HashAlgorithm, ByRef sHash As String) As Long
Dim lhFile As Long
Dim lFileSize As Long
Dim lRet As Long
Dim lhContext As Long
Dim lhHash As Long
Dim tFile As tFileChunks
Dim lSize As Long
If Not PathFileExists(sFile) = 0 Then
lhFile = CreateFile(sFile, _
GENERIC_READ, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, _
ByVal 0&, OPEN_EXISTING, 0, 0)
If Not lhFile = INVALID_HANDLE_VALUE Then
lFileSize = GetFileSize(lhFile, 0&)
If Not lFileSize = 0 Then
lRet = CryptAcquireContext(lhContext, _
vbNullString, vbNullString, _
PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)
If Not lRet = 0 Then
lRet = CryptCreateHash(lhContext, _
eHash, 0, 0, lhHash)
If Not lRet = 0 Then
With tFile
ReDim .bvChunck(1 To BLOCK_SIZE)
.lChuncks = lFileSize \ BLOCK_SIZE
.lReminder = lFileSize - .lChuncks * BLOCK_SIZE
If Not .lReminder = 0 Then
ReDim .bvReminder(1 To .lReminder)
End If
For .lCount = 1 To .lChuncks
Call ReadFile(lhFile, .bvChunck(1), BLOCK_SIZE, 0&, 0&)
If CryptHashData(lhHash, .bvChunck(1), BLOCK_SIZE, 0) = 0 Then
Exit For
End If
Next
If Not .lReminder = 0 Then
Call ReadFile(lhFile, .bvReminder(1), .lReminder, 0&, 0&)
lRet = CryptHashData(lhHash, .bvReminder(1), .lReminder, 0)
End If
lRet = CryptGetHashParam(lhHash, HP_HASHSIZE, lSize, 4, 0)
If Not lRet = 0 Then
ReDim .bvReminder(0 To lSize - 1)
lRet = CryptGetHashParam(lhHash, HP_HASHVAL, .bvReminder(0), lSize, 0)
If Not lRet = 0 Then
.lCount = 0
For .lCount = 0 To UBound(.bvReminder)
sHash = sHash & Right$("0" & Hex$(.bvReminder(.lCount)), 2)
Next
Else
HashFile = 7
End If
Else
HashFile = 6
End If
End With
Else
HashFile = 5
End If
Else
HashFile = 4
End If
Else
HashFile = 3
End If
Else
HashFile = 2
End If
Else
HashFile = 1
End If
Call CryptDestroyHash(lhHash)
Call CryptReleaseContext(lhContext, 0)
Call CloseHandle(lhFile)
End Function
Creditos: Cobein.¡1
Hash para Texto (MD5)
En un Modulo:
Option Explicit
Private lngTrack As Long
Private arrLongConversion(4) As Long
Private arrSplit64(63) As Byte
Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647
Private Const S11 = 7
Private Const S12 = 12
Private Const S13 = 17
Private Const S14 = 22
Private Const S21 = 5
Private Const S22 = 9
Private Const S23 = 14
Private Const S24 = 20
Private Const S31 = 4
Private Const S32 = 11
Private Const S33 = 16
Private Const S34 = 23
Private Const S41 = 6
Private Const S42 = 10
Private Const S43 = 15
Private Const S44 = 21
Private Function MD5Round(strRound As String, a As Long, _
b As Long, C As Long, d As Long, X As Long, S As Long, _
ac As Long) As Long
Select Case strRound
Case Is = "FF"
a = MD5LongAdd4(a, (b And C) Or (Not (b) And d), X, ac)
a = MD5Rotate(a, S)
a = MD5LongAdd(a, b)
Case Is = "GG"
a = MD5LongAdd4(a, (b And d) Or (C And Not (d)), X, ac)
a = MD5Rotate(a, S)
a = MD5LongAdd(a, b)
Case Is = "HH"
a = MD5LongAdd4(a, b Xor C Xor d, X, ac)
a = MD5Rotate(a, S)
a = MD5LongAdd(a, b)
Case Is = "II"
a = MD5LongAdd4(a, C Xor (b Or Not (d)), X, ac)
a = MD5Rotate(a, S)
a = MD5LongAdd(a, b)
End Select
End Function
Private Function MD5Rotate(lngValue As Long, lngBits As Long) As Long
Dim lngSign As Long
Dim lngI As Long
lngBits = (lngBits Mod 32)
If lngBits = 0 Then MD5Rotate = lngValue: Exit Function
For lngI = 1 To lngBits
lngSign = lngValue And &HC0000000
lngValue = (lngValue And &H3FFFFFFF) * 2
lngValue = lngValue Or ((lngSign < 0) And 1) Or _
(CBool(lngSign And &H40000000) And &H80000000)
Next
MD5Rotate = lngValue
End Function
Private Function TRID() As String
Dim sngNum As Single, lngnum As Long
Dim strResult As String
sngNum = Rnd(2147483648#)
strResult = CStr(sngNum)
strResult = Replace(strResult, "0.", "")
strResult = Replace(strResult, ".", "")
strResult = Replace(strResult, "E-", "")
TRID = strResult
End Function
Private Function MD564Split(lngLength As Long, bytBuffer() As Byte) As String
Dim lngBytesTotal As Long, lngBytesToAdd As Long
Dim intLoop As Integer, intLoop2 As Integer, lngTrace As Long
Dim intInnerLoop As Integer, intLoop3 As Integer
lngBytesTotal = lngTrack Mod 64
lngBytesToAdd = 64 - lngBytesTotal
lngTrack = (lngTrack + lngLength)
If lngLength >= lngBytesToAdd Then
For intLoop = 0 To lngBytesToAdd - 1
arrSplit64(lngBytesTotal + intLoop) = bytBuffer(intLoop)
Next intLoop
MD5Conversion arrSplit64
lngTrace = (lngLength) Mod 64
For intLoop2 = lngBytesToAdd To lngLength - intLoop - lngTrace Step 64
For intInnerLoop = 0 To 63
arrSplit64(intInnerLoop) = bytBuffer(intLoop2 + intInnerLoop)
Next intInnerLoop
MD5Conversion arrSplit64
Next intLoop2
lngBytesTotal = 0
Else
intLoop2 = 0
End If
For intLoop3 = 0 To lngLength - intLoop2 - 1
arrSplit64(lngBytesTotal + intLoop3) = bytBuffer(intLoop2 + intLoop3)
Next intLoop3
End Function
Private Function MD5StringArray(strInput As String) As Byte()
Dim intLoop As Integer
Dim bytBuffer() As Byte
ReDim bytBuffer(Len(strInput))
For intLoop = 0 To Len(strInput) - 1
bytBuffer(intLoop) = Asc(Mid(strInput, intLoop + 1, 1))
Next intLoop
MD5StringArray = bytBuffer
End Function
Private Sub MD5Conversion(bytBuffer() As Byte)
Dim X(16) As Long, a As Long
Dim b As Long, C As Long
Dim d As Long
a = arrLongConversion(1)
b = arrLongConversion(2)
C = arrLongConversion(3)
d = arrLongConversion(4)
MD5Decode 64, X, bytBuffer
MD5Round "FF", a, b, C, d, X(0), S11, -680876936
MD5Round "FF", d, a, b, C, X(1), S12, -389564586
MD5Round "FF", C, d, a, b, X(2), S13, 606105819
MD5Round "FF", b, C, d, a, X(3), S14, -1044525330
MD5Round "FF", a, b, C, d, X(4), S11, -176418897
MD5Round "FF", d, a, b, C, X(5), S12, 1200080426
MD5Round "FF", C, d, a, b, X(6), S13, -1473231341
MD5Round "FF", b, C, d, a, X(7), S14, -45705983
MD5Round "FF", a, b, C, d, X(8), S11, 1770035416
MD5Round "FF", d, a, b, C, X(9), S12, -1958414417
MD5Round "FF", C, d, a, b, X(10), S13, -42063
MD5Round "FF", b, C, d, a, X(11), S14, -1990404162
MD5Round "FF", a, b, C, d, X(12), S11, 1804603682
MD5Round "FF", d, a, b, C, X(13), S12, -40341101
MD5Round "FF", C, d, a, b, X(14), S13, -1502002290
MD5Round "FF", b, C, d, a, X(15), S14, 1236535329
MD5Round "GG", a, b, C, d, X(1), S21, -165796510
MD5Round "GG", d, a, b, C, X(6), S22, -1069501632
MD5Round "GG", C, d, a, b, X(11), S23, 643717713
MD5Round "GG", b, C, d, a, X(0), S24, -373897302
MD5Round "GG", a, b, C, d, X(5), S21, -701558691
MD5Round "GG", d, a, b, C, X(10), S22, 38016083
MD5Round "GG", C, d, a, b, X(15), S23, -660478335
MD5Round "GG", b, C, d, a, X(4), S24, -405537848
MD5Round "GG", a, b, C, d, X(9), S21, 568446438
MD5Round "GG", d, a, b, C, X(14), S22, -1019803690
MD5Round "GG", C, d, a, b, X(3), S23, -187363961
MD5Round "GG", b, C, d, a, X(8), S24, 1163531501
MD5Round "GG", a, b, C, d, X(13), S21, -1444681467
MD5Round "GG", d, a, b, C, X(2), S22, -51403784
MD5Round "GG", C, d, a, b, X(7), S23, 1735328473
MD5Round "GG", b, C, d, a, X(12), S24, -1926607734
MD5Round "HH", a, b, C, d, X(5), S31, -378558
MD5Round "HH", d, a, b, C, X(8), S32, -2022574463
MD5Round "HH", C, d, a, b, X(11), S33, 1839030562
MD5Round "HH", b, C, d, a, X(14), S34, -35309556
MD5Round "HH", a, b, C, d, X(1), S31, -1530992060
MD5Round "HH", d, a, b, C, X(4), S32, 1272893353
MD5Round "HH", C, d, a, b, X(7), S33, -155497632
MD5Round "HH", b, C, d, a, X(10), S34, -1094730640
MD5Round "HH", a, b, C, d, X(13), S31, 681279174
MD5Round "HH", d, a, b, C, X(0), S32, -358537222
MD5Round "HH", C, d, a, b, X(3), S33, -722521979
MD5Round "HH", b, C, d, a, X(6), S34, 76029189
MD5Round "HH", a, b, C, d, X(9), S31, -640364487
MD5Round "HH", d, a, b, C, X(12), S32, -421815835
MD5Round "HH", C, d, a, b, X(15), S33, 530742520
MD5Round "HH", b, C, d, a, X(2), S34, -995338651
MD5Round "II", a, b, C, d, X(0), S41, -198630844
MD5Round "II", d, a, b, C, X(7), S42, 1126891415
MD5Round "II", C, d, a, b, X(14), S43, -1416354905
MD5Round "II", b, C, d, a, X(5), S44, -57434055
MD5Round "II", a, b, C, d, X(12), S41, 1700485571
MD5Round "II", d, a, b, C, X(3), S42, -1894986606
MD5Round "II", C, d, a, b, X(10), S43, -1051523
MD5Round "II", b, C, d, a, X(1), S44, -2054922799
MD5Round "II", a, b, C, d, X(8), S41, 1873313359
MD5Round "II", d, a, b, C, X(15), S42, -30611744
MD5Round "II", C, d, a, b, X(6), S43, -1560198380
MD5Round "II", b, C, d, a, X(13), S44, 1309151649
MD5Round "II", a, b, C, d, X(4), S41, -145523070
MD5Round "II", d, a, b, C, X(11), S42, -1120210379
MD5Round "II", C, d, a, b, X(2), S43, 718787259
MD5Round "II", b, C, d, a, X(9), S44, -343485551
arrLongConversion(1) = MD5LongAdd(arrLongConversion(1), a)
arrLongConversion(2) = MD5LongAdd(arrLongConversion(2), b)
arrLongConversion(3) = MD5LongAdd(arrLongConversion(3), C)
arrLongConversion(4) = MD5LongAdd(arrLongConversion(4), d)
End Sub
Private Function MD5LongAdd(lngVal1 As Long, lngVal2 As Long) As Long
Dim lngHighWord As Long
Dim lngLowWord As Long
Dim lngOverflow As Long
lngLowWord = (lngVal1 And &HFFFF&) + (lngVal2 And &HFFFF&)
lngOverflow = lngLowWord \ 65536
lngHighWord = (((lngVal1 And &HFFFF0000) \ 65536) _
+ ((lngVal2 And &HFFFF0000) \ 65536) _
+ lngOverflow) And &HFFFF&
MD5LongAdd = MD5LongConversion((lngHighWord * 65536#) _
+ (lngLowWord And &HFFFF&))
End Function
Private Function MD5LongAdd4(lngVal1 As Long, _
lngVal2 As Long, lngVal3 As Long, lngVal4 As Long) As Long
Dim lngHighWord As Long
Dim lngLowWord As Long
Dim lngOverflow As Long
lngLowWord = (lngVal1 And &HFFFF&) _
+ (lngVal2 And &HFFFF&) _
+ (lngVal3 And &HFFFF&) _
+ (lngVal4 And &HFFFF&)
lngOverflow = lngLowWord \ 65536
lngHighWord = (((lngVal1 And &HFFFF0000) \ 65536) _
+ ((lngVal2 And &HFFFF0000) \ 65536) _
+ ((lngVal3 And &HFFFF0000) \ 65536) _
+ ((lngVal4 And &HFFFF0000) \ 65536) _
+ lngOverflow) And &HFFFF&
MD5LongAdd4 = MD5LongConversion((lngHighWord * 65536#) _
+ (lngLowWord And &HFFFF&))
End Function
Private Sub MD5Decode(intLength As Integer, _
lngOutBuffer() As Long, bytInBuffer() As Byte)
Dim intDblIndex As Integer
Dim intByteIndex As Integer
Dim dblSum As Double
intDblIndex = 0
For intByteIndex = 0 To intLength - 1 Step 4
dblSum = bytInBuffer(intByteIndex) + bytInBuffer(intByteIndex + 1) _
* 256# + bytInBuffer(intByteIndex + 2) _
* 65536# + bytInBuffer(intByteIndex + 3) * 16777216#
lngOutBuffer(intDblIndex) = MD5LongConversion(dblSum)
intDblIndex = (intDblIndex + 1)
Next intByteIndex
End Sub
Private Function MD5LongConversion(dblValue As Double) As Long
If dblValue < 0 Or dblValue >= OFFSET_4 Then Error 6
If dblValue <= MAXINT_4 Then
MD5LongConversion = dblValue
Else
MD5LongConversion = dblValue - OFFSET_4
End If
End Function
Private Sub MD5Finish()
Dim dblBits As Double
Dim arrPadding(72) As Byte
Dim lngBytesBuffered As Long
arrPadding(0) = &H80
dblBits = lngTrack * 8
lngBytesBuffered = lngTrack Mod 64
If lngBytesBuffered <= 56 Then
MD564Split (56 - lngBytesBuffered), arrPadding
Else
MD564Split (120 - lngTrack), arrPadding
End If
arrPadding(0) = MD5LongConversion(dblBits) And &HFF&
arrPadding(1) = MD5LongConversion(dblBits) \ 256 And &HFF&
arrPadding(2) = MD5LongConversion(dblBits) \ 65536 And &HFF&
arrPadding(3) = MD5LongConversion(dblBits) \ 16777216 And &HFF&
arrPadding(4) = 0
arrPadding(5) = 0
arrPadding(6) = 0
arrPadding(7) = 0
MD564Split 8, arrPadding
End Sub
Private Function MD5StringChange(lngnum As Long) As String
Dim bytA As Byte
Dim bytB As Byte
Dim bytC As Byte
Dim bytD As Byte
bytA = lngnum And &HFF&
If bytA < 16 Then
MD5StringChange = "0" & Hex(bytA)
Else
MD5StringChange = Hex(bytA)
End If
bytB = (lngnum And &HFF00&) \ 256
If bytB < 16 Then
MD5StringChange = MD5StringChange & "0" & Hex(bytB)
Else
MD5StringChange = MD5StringChange & Hex(bytB)
End If
bytC = (lngnum And &HFF0000) \ 65536
If bytC < 16 Then
MD5StringChange = MD5StringChange & "0" & Hex(bytC)
Else
MD5StringChange = MD5StringChange & Hex(bytC)
End If
If lngnum < 0 Then
bytD = ((lngnum And &H7F000000) \ 16777216) Or &H80&
Else
bytD = (lngnum And &HFF000000) \ 16777216
End If
If bytD < 16 Then
MD5StringChange = MD5StringChange & "0" & Hex(bytD)
Else
MD5StringChange = MD5StringChange & Hex(bytD)
End If
End Function
Private Function MD5Value() As String
MD5Value = LCase(MD5StringChange(arrLongConversion(1)) & _
MD5StringChange(arrLongConversion(2)) & _
MD5StringChange(arrLongConversion(3)) & _
MD5StringChange(arrLongConversion(4)))
End Function
Public Function CalculateMD5(strMessage As String) As String
Dim bytBuffer() As Byte
bytBuffer = MD5StringArray(strMessage)
MD5Start
MD564Split Len(strMessage), bytBuffer
MD5Finish
CalculateMD5 = MD5Value
End Function
Private Sub MD5Start()
lngTrack = 0
arrLongConversion(1) = MD5LongConversion(1732584193#)
arrLongConversion(2) = MD5LongConversion(4023233417#)
arrLongConversion(3) = MD5LongConversion(2562383102#)
arrLongConversion(4) = MD5LongConversion(271733878#)
End Sub
Con el modulo anterior en un Formualrio:
Private Sub Command1_Click()
Text2.Text = CalculateMD5(Text1.Text)
End Sub
De este ultimo desconozco los creditos...
Dulces Lunas
Autor
En línea
