VB6校验文件防破解

1Private Sub Form_Load()
2 Dim str As String
3str = IIf(Len(App.Path) > 3, App.Path & "\" & App.EXEName & ".exe", App.Path & App.EXEName & ".exe")
4Print "MD5:" & HashFile(str) '获取exe文件的MD5校验码
5Print "大小:" & FileLen(str) & " 字节"  '取当前体积大小
6End Sub

  1Option Explicit
  2Private Declare Function CryptAcquireContext Lib "advapi32.dll" _
  3Alias "CryptAcquireContextA" ( _
  4ByRef phProv As Long, _
  5ByVal pszContainer As String, _
  6ByVal pszProvider As String, _
  7ByVal dwProvType As Long, _
  8ByVal dwFlags As Long) As Long
  9Private Declare Function CryptReleaseContext Lib "advapi32.dll" ( _
 10ByVal hProv As Long, _
 11ByVal dwFlags As Long) As Long
 12Private Declare Function CryptCreateHash Lib "advapi32.dll" ( _
 13ByVal hProv As Long, _
 14ByVal Algid As Long, _
 15ByVal hKey As Long, _
 16ByVal dwFlags As Long, _
 17ByRef phHash As Long) As Long
 18Private Declare Function CryptDestroyHash Lib "advapi32.dll" ( _
 19ByVal hHash As Long) As Long
 20Private Declare Function CryptHashData Lib "advapi32.dll" ( _
 21ByVal hHash As Long, _
 22pbData As Any, _
 23ByVal dwDataLen As Long, _
 24ByVal dwFlags As Long) As Long
 25Private Declare Function CryptGetHashParam Lib "advapi32.dll" ( _
 26ByVal hHash As Long, _
 27ByVal dwParam As Long, _
 28pbData As Any, _
 29pdwDataLen As Long, _
 30ByVal dwFlags As Long) As Long
 31Private Const PROV_RSA_FULL = 1
 32Private Const CRYPT_NEWKEYSET = &H8
 33Private Const ALG_CLASS_HASH = 32768
 34Private Const ALG_TYPE_ANY = 0
 35Private Const ALG_SID_MD2 = 1
 36Private Const ALG_SID_MD4 = 2
 37Private Const ALG_SID_MD5 = 3
 38Private Const ALG_SID_SHA1 = 4
 39Enum HashAlgorithm
 40MD2 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2
 41MD4 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4
 42MD5 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5
 43SHA1 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA1
 44End Enum
 45Private Const HP_HASHVAL = 2
 46Private Const HP_HASHSIZE = 4
 47Function HashFile( _
 48ByVal FileName As String, _
 49Optional ByVal Algorithm As HashAlgorithm = MD5) As String
 50Dim hCtx As Long
 51Dim hHash As Long
 52Dim lFile As Long
 53Dim lRes As Long
 54Dim lLen As Long
 55Dim lIdx As Long
 56Dim abHash() As Byte
 57If Len(Dir$(FileName)) = 0 Then Err.Raise 53
 58lRes = CryptAcquireContext(hCtx, vbNullString, _
 59vbNullString, PROV_RSA_FULL, 0)
 60If lRes = 0 And Err.LastDllError = &H80090016 Then
 61lRes = CryptAcquireContext(hCtx, vbNullString, _
 62vbNullString, PROV_RSA_FULL, CRYPT_NEWKEYSET)
 63End If
 64If lRes <> 0 Then
 65lRes = CryptCreateHash(hCtx, Algorithm, 0, 0, hHash)
 66If lRes <> 0 Then
 67lFile = FreeFile
 68Open FileName For Binary As lFile
 69If Err.Number = 0 Then
 70Const BLOCK_SIZE As Long = 32 * 1024& ' 32K
 71ReDim abBlock(1 To BLOCK_SIZE) As Byte
 72Dim lCount As Long
 73Dim lBlocks As Long
 74Dim lLastBlock As Long
 75lBlocks = LOF(lFile) \ BLOCK_SIZE
 76lLastBlock = LOF(lFile) - lBlocks * BLOCK_SIZE
 77For lCount = 1 To lBlocks
 78Get lFile, , abBlock
 79lRes = CryptHashData(hHash, abBlock(1), BLOCK_SIZE, 0)
 80If lRes = 0 Then Exit For
 81Next
 82If lLastBlock > 0 And lRes <> 0 Then
 83ReDim abBlock(1 To lLastBlock) As Byte
 84Get lFile, , abBlock
 85lRes = CryptHashData(hHash, abBlock(1), lLastBlock, 0)
 86End If
 87Close lFile
 88End If
 89If lRes <> 0 Then
 90lRes = CryptGetHashParam(hHash, HP_HASHSIZE, lLen, 4, 0)
 91If lRes <> 0 Then
 92ReDim abHash(0 To lLen - 1)
 93lRes = CryptGetHashParam(hHash, HP_HASHVAL, abHash(0), lLen, 0)
 94If lRes <> 0 Then
 95For lIdx = 0 To UBound(abHash)
 96HashFile = HashFile & _
 97Right$("0" & Hex$(abHash(lIdx)), 2)
 98Next
 99End If
100End If
101End If
102CryptDestroyHash hHash
103End If
104End If
105CryptReleaseContext hCtx, 0
106If lRes = 0 Then Err.Raise Err.LastDllError
107End Function