1 Private Sub Text1_OLEDragDrop(Data As DataObject,Effect As Long,Button As Integer,Shift As Integer,X As Single,Y As Single)
 2     Dim path As String,hash As String
 3     For Each file In Data.Files
 4         path = path & file
 5     Next
 6     If (GetAttr(path) And vbDirectory) = vbDirectory Then
 7         MsgBox "请勿拖放文件夹，谢谢！",vbExclamation,"提示"
 8     Else
 9         hash = HashFile(path)
10         Text1.Text = Text1.Text & "文件路径： " & path & vbCrLf _
11                                 & "创建时间： " & FileDateTime(path) & vbCrLf _
12                                 & "文件大小： " & FileLen(path) & " 字节" & vbCrLf _
13                                 & "文件HASH： " & hash & vbCrLf & vbCrLf
14     End If
15 End Sub

 1 Public 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
 2 Public Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long,ByVal dwFlags As Long) As Long
 3 Public 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
 4 Public Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
 5 Public Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long,pbData As Any,ByVal dwDataLen As Long,ByVal dwFlags As Long) As Long
 6 Public Declare Function CryptGetHashParam Lib "advapi32.dll" (ByVal hHash As Long,ByVal dwParam As Long,pdwDataLen As Long,ByVal dwFlags As Long) As Long
 7 Public Const PROV_RSA_FULL = 1
 8 Public Const CRYPT_NEWKEYSET = &H8
 9 Public Const ALG_CLASS_HASH = 32768
10 Public Const ALG_TYPE_ANY = 0
11 Public Const ALG_SID_MD2 = 1
12 Public Const ALG_SID_MD4 = 2
13 Public Const ALG_SID_MD5 = 3
14 Public Const ALG_SID_SHA1 = 4
15 Enum HashAlgorithm
16    MD2 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2
17    MD4 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4
18    MD5 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5
19    SHA1 = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA1
20 End Enum
21 Public Const HP_HASHVAL = 2
22 Public Const HP_HASHSIZE = 4
23 
24 Public Function HashFile(ByVal FileName As String,Optional ByVal Algorithm As HashAlgorithm = MD5) As String
25     Dim hCtx As Long
26     Dim hHash As Long
27     Dim lFile As Long
28     Dim lRes As Long
29     Dim lLen As Long
30     Dim lIdx As Long
31     Dim abHash() As Byte
32     If Len(Dir$(FileName)) = 0 Then Err.Raise 53
33     lRes = CryptAcquireContext(hCtx,vbNullString,PROV_RSA_FULL,0)
34     If lRes = 0 And Err.LastDllError = &H80090016 Then
35       lRes = CryptAcquireContext(hCtx,CRYPT_NEWKEYSET)
36     End If
37     If lRes <> 0 Then
38        lRes = CryptCreateHash(hCtx,Algorithm,0,0,hHash)
39        If lRes <> 0 Then
40           lFile = FreeFile
41           Open FileName For Binary As lFile
42           If Err.Number = 0 Then
43              Const BLOCK_SIZE As Long = 32 * 1024& ‘ 32K
44              ReDim abBlock(1 To BLOCK_SIZE) As Byte
45              Dim lCount As Long
46              Dim lBlocks As Long
47              Dim lLastBlock As Long
48              lBlocks = LOF(lFile) \ BLOCK_SIZE
49              lLastBlock = LOF(lFile) - lBlocks * BLOCK_SIZE
50              For lCount = 1 To lBlocks
51                 Get lFile,abBlock
52                 lRes = CryptHashData(hHash,abBlock(1),BLOCK_SIZE,0)
53                 If lRes = 0 Then Exit For
54              Next
55              If lLastBlock > 0 And lRes <> 0 Then
56                 ReDim abBlock(1 To lLastBlock) As Byte
57                 Get lFile,abBlock
58                 lRes = CryptHashData(hHash,lLastBlock,0)
59              End If
60              Close lFile
61           End If
62           If lRes <> 0 Then
63              lRes = CryptGetHashParam(hHash,HP_HASHSIZE,lLen,4,0)
64              If lRes <> 0 Then
65                  ReDim abHash(0 To lLen - 1)
66                  lRes = CryptGetHashParam(hHash,HP_HASHVAL,abHash(0),0)
67                  If lRes <> 0 Then
68                      For lIdx = 0 To UBound(abHash)
69                          HashFile = HashFile & Right$("0" & Hex$(abHash(lIdx)),2)
70                          DoEvents
71                      Next
72                  End If
73              End If
74           End If
75           CryptDestroyHash hHash
76        End If
77     End If
78     CryptReleaseContext hCtx,0
79     If lRes = 0 Then Err.Raise Err.LastDllError
80 End Function