ReturnString = EncryptedText
CryptoEncrypt = True
Finished:
If (lHkey) Then lResult = CryptDestroyKey(lHkey)
If (lHExchgKey) Then lResult 3D CryptDestroyKey(lHExchgKey)0D
If (lHHash) Then lResult = CryptDestroyHash(lHHash)
0AIf (lHCryptprov) Then lResult = CryptReleaseContext(lHCryptprov, 0)
Exit Function
DecryptError:
MsgBox "decrypt error:" & Error$
GoTo Finished
End Function
Public Function CryptoDecrypt(InputString As String, _
sPassword As String, ReturnString As String) As Boolean
0ADim lHExchgKey As Long, lHCryptprov As Long, lHHash As Long0D
Dim lHkey As Long, lResult As Long, lPasswordCount As Long0D
Dim lDecryptBufLen As Long, lDecryptPoint As Long, lPasswordPoint As Long
Dim DecryptedText As String, sContainer As String, sProvider As String
Dim sDecryptBuffer As String0D
Dim i As Integer
On Error GoTo DecryptError
0ACryptoDecrypt = False
sContainer = vbNullChar
sProvider = vbNullChar
sProvider = MS_DEF_PROV & vbNullChar
If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, _
ByVal sProvider, PROV_RSA_FULL, 0)) Then
MsgBox "Error" & CStr(GetLastError) & "during Cry
ptAcquireContext!"
GoTo Finished
End If
If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then
MsgBox "Error" & CStr(GetLastError) & "during Cry
ptCreateHash!"
GoTo Finished
End If
If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
MsgBox "Error" & CStr(GetLastError) & "during Cry
ptHashData!"
GoTo Finished
End If
If Not CBool(CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, _
0, lHkey)) Then
MsgBox "Error" & CStr(GetLastError) & "during Cry
ptDeriveKey!"
GoTo Finished
End If
CryptDestroyHash (lHHash)
0AlHHash = 0
ReturnString = ""
For i = 1 To Len(InputString) Step 255
sDecryptBuffer = Mid(InputString, i, 255)
0AlDecryptBufLen = Len(sDecryptBuffer)
If Not CBool(CryptDecrypt(lHkey, 0, 1, 0, sDecryptBuffer, _0D
lDecryptBufLen)) Then
MsgBox "Error" & CStr(GetLastError) & "duri
ng CryptDecrypt!"
GoTo Finished
Else
DecryptedText = DecryptedText & sDecryptBuffer
End If
Next i
ReturnString = DecryptedText
CryptoDecrypt = True
Finished:
If (lHkey) Then lResult = CryptDestroyKey(lHkey)
If (lHExchgKey) Then lResult 3D CryptDestroyKey(lHExchgKey)0D
If (lHHash) Then lResult = CryptDestroyHash(lHHash)
0AIf (lHCryptprov) Then lResult = CryptReleaseContext(lHCryptprov, 0)
Exit Function
DecryptError:
MsgBox "decrypt error:" & Error$
GoTo Finished
MD5的全称是Message-Digest Algorithm 5(信息-摘要算法),在90年代初由MIT Laboratory for Computer Science和RSA Data Security Inc的Ronald L. Rivest开发出来,经MD2、MD3和MD4发展而来。它的作用是让大容量信息在用数字签名软件签署私人密匙前被"压缩"成一种保密的格式(就是把一个任意长度的字节串变换成一定长的大整数)。不管是MD2、MD4还是MD5,它们都需要获得一个随机长度的信息并产生一个128位的信息摘要。虽然这些算法的结构或多或少有些相似,但MD2的设计与MD4和MD5完全不同,那是因为MD2是为8位机器做过设计优化的,而MD4和MD5却是面向32位的电脑。这三个算法的描述和C语言源代码在Internet RFCs 1321中有详细的描述(http://www.ietf.org/rfc/rfc1321.txt),这是一份最权威的文档,由Ronald L. Rivest在1992年8月向IEFT提交。
Van Oorschot和Wiener曾经考虑过一个在散列中暴力搜寻冲突的函数(Brute-Force Hash Function),而且他们猜测一个被设计专门用来搜索MD5冲突的机器(这台机器在1994年的制造成本大约是一百万美元)可以平均每24天就找到一个冲突。但单从1991年到2001年这10年间,竟没有出现替代MD5算法的MD6或被叫做其他什么名字的新算法这一点,我们就可以看出这个瑕疵并没有太多的影响MD5的安全性。上面所有这些都不足以成为MD5的在实际应用中的问题。并且,由于MD5算法的使用不需要支付任何版权费用的,所以在一般的情况下(非绝密应用领域。但即便是应用在绝密领域内,MD5也不失为一种非常优秀的中间技术),MD5怎么都应该算得上是非常安全的了。
Declare Function CryptAcquireContext Lib "advapi32.dll" Alias _
"CryptAcquireContextA" (phProv As Long, _
pszContainer As String, _
0ApszProvider As String, _
ByVal dwprovType As Long, _
ByVal dwFlags As Long) As Long
Declare Function CryptCreateHash Lib "advapi32.dll" _
(ByVal hProv As Long, _
ByVal Algid As Long, _
ByVal hKey As Long, _
ByVal dwFlags As Long, _
phHash As Long) As Long
Declare Function CryptHashData Lib "advapi32.dll" _
(ByVal hHash As Long, _
ByVal pbData As String, _
0AByVal dwDataLen As Long, _
0AByVal dwFlags As Long) As Long
Declare Function CryptDeriveKey Lib "advapi32.dll" _
(ByVal hProv As Long, _
ByVal Algid As Long, _
ByVal hBaseData As Long, _
0AByVal dwFlags As Long, _
phKey As Long) As Long
Declare Function CryptDestroyHash Lib "advapi32.dll" _
(ByVal hHash As Long) As Long0D
Declare Function CryptDestroyKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long0D
Declare Function CryptEncrypt Lib "advapi32.dll" _
(ByVal hKey As Long, _
ByVal hHash As Long, _
ByVal Final As Long, _
ByVal dwFlags As Long, _
ByVal pbData As String, _
0AByVal dwDataLen As Long, _
0AByVal dwBufLen As Long) As Long
Declare Function CryptDecrypt Lib "advapi32.dll" _
(ByVal hKey As Long, _
ByVal hHash As Long, _
ByVal Final As Long, _
ByVal dwFlags As Long, _
ByVal pbData As String, _
0AByVal dwDataLen As Long) As Long
Declare Function CryptReleaseContext Lib "advapi32.dll" _
(ByVal hProv As Long, _
ByVal dwFlags As Long) As Long
Declare Function CryptGetProvParam Lib "advapi32.dll" _
0A(ByVal hProv As Long, _
ByVal dwParam As Long, _
ByVal pbData As String, _
0AByVal pdwDataLen As Long, _
ByVal dwFlags As Long) As Long
Declare Function CryptGetUserKey Lib "advapi32.dll" _
(ByVal hProv As Long, _
ByVal dwKeySpec As Long, _
0AByVal phUserKey As Long) As Long
Declare Function CryptGenKey Lib "advapi32.dll" _
(ByVal hProv As Long, _
ByVal Algid As Long, _
ByVal dwFlags As Long, _
ByVal phKey As Long) As Long0D
Declare Function GetLastError Lib "Kernel32.dll" () As Long0D
Public Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0&
quot;
Public Const PROV_RSA_FULL = 1
Public Const ALG_CLASS_DATA_ENCRYPT = 24576
Public Const ALG_CLASS_HASH 3D 32768
Public Const ALG_TYPE_ANY = 0
Public Const ALG_TYPE_BLOCK 3D 1536
Public Const ALG_TYPE_STREAM 3D 2048
Public Const ALG_SID_RC2 = 2
Public Const ALG_SID_RC4 = 1
Public Const ALG_SID_MD5 = 3
Public Const CALG_MD5 = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
Public Const CALG_RC2 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK) Or ALG_S
ID_RC2)
Public Const CALG_RC4 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_
SID_RC4)
Public Const ENCRYPT_ALGORITHM = CALG_RC4
Public Const ENCRYPT_BLOCK_SIZE = 1
Public Const CRYPT_EXPORTABLE = 1
Public Const CRYPT_NEWKEYSET 3D 8
Public Const PP_CONTAINER = 6
Public Const AT_SIGNATURE = 2
Public EncryptetNotSaved As Boolean
Public DecryptetNotSaved As Boolean
Function InitUser() As Boolean
Dim hProv As Long, hKey As Long, dwUserNameLen As Long
Dim szUserName As String, sContainer As String
InitUser = False
dwUserNameLen = 100
sContainer = vbNullChar
If Not CBool(CryptAcquireContext(hProv, ByVal sContainer, _0D
ByVal MS_DEF_PROV, PROV_RSA_FULL, 0)) Then
MsgBox "容器未找到……创建缺省密钥容器!", vbInformation
If Not CBool(CryptAcquireContext(hProv, ByVal sContainer, _0D
ByVal MS_DEF_PROV, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
0AMsgBox "密钥容器创建错误!", vbInformation
Exit Function
End If
If Not CBool(CryptAcquireContext(ByVal hProv, PP_CONTAINER, _
szUserName, dwUserNameLen, 0)) Then
MsgBox "获取密钥容器名称错误!", vbInformation
szUserName = ""
Exit Function
End If
Else
MsgBox "初始化缺省密钥容器" & vbCrLf & "加密/解密
:一切就绪。", vbInformation
InitUser = True
End If
If Not CBool(CryptGetUserKey(ByVal hProv, AT_SIGNATURE, hKey)) Then
If Not CBool(CryptGenKey(ByVal hProv, AT_SIGNATURE, 0, hKey)) Then
MsgBox "CryptGenKey 错误!", vbCritical
InitUser = False
Exit Function
Else
CryptDestroyKey ByVal hKey
0AInitUser = True
End If
Else
MsgBox "CryptGetuserKey 错误!", vbCritical
Exit Function
End If
End Function
Public Function CryptoEncrypt(StringToEncrypt As String, _0D
sPassword As String, ReturnString As String) As Boolean
0ADim lHHash As Long, lHkey As Long, lResult As Long
Dim lHExchgKey As Long, lHCryptprov As Long, lCryptLength As Long
Dim lPasswordCount As Long
0ADim lcryptBufLen As Long
Dim sContainer As String, InputString As String, sProvider As String
Dim EncryptedText As String
Dim i As Integer
On Error GoTo DecryptError
0ACryptoEncrypt = False
sContainer = vbNullChar
sProvider = vbNullChar
sProvider = MS_DEF_PROV & vbNullChar
If Not CBool(CryptAcquireContext(lHCryptprov, ByVal sContainer, _
ByVal sProvider, PROV_RSA_FULL, 0)) Then
MsgBox "Error" & CStr(GetLastError) & "during Cry
ptAcquireContext!"
GoTo Finished
End If
If Not CBool(CryptCreateHash(lHCryptprov, CALG_MD5, 0, 0, lHHash)) Then
MsgBox "Error" & CStr(GetLastError) & "during Cry
ptCreateHash!"
GoTo Finished
End If
If Not CBool(CryptHashData(lHHash, sPassword, Len(sPassword), 0)) Then
MsgBox "Error" & CStr(GetLastError) & "during Cry
ptHashData!"
GoTo Finished
End If
If Not CBool(CryptDeriveKey(lHCryptprov, ENCRYPT_ALGORITHM, lHHash, _
0, lHkey)) Then
MsgBox "Error" & CStr(GetLastError) & "during Cry
ptDeriveKey!"
GoTo Finished
End If
CryptDestroyHash (lHHash)
0AlHHash = 0
ReturnString = ""
For i = 1 To Len(StringToEncrypt) Step 255
InputString = Mid(StringToEncrypt, i, 255)0D
lCryptLength = Len(InputString)
lcryptBufLen = lCryptLength * 2
If Not CBool(CryptEncrypt(lHkey, 0, 1, 0, InputString, _
0AlCryptLength, lcryptBufLen)) Then
MsgBox "Error" & CStr(GetLastError) & "duri
ng CryptDecrypt!"
GoTo Finished
Else
EncryptedText = EncryptedText & InputString
End If
Next i