根据网络资料整改,来源未知,已调试通过.
Option Explicit
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 Any, _
ByVal dwDataLen As Long, _
ByVal dwFlags As Long) As Long Private Declare Function CryptDeriveKey Lib "advapi32.dll" ( _
ByVal hProv As Long, _
ByVal Algid As Long, _
ByVal hBaseData As Long, _
ByVal dwFlags As Long, _
ByRef phKey As Long) As Long Private Declare Function CryptDestroyKey Lib "advapi32.dll" ( _
ByVal hKey As Long) As Long Private Declare Function CryptEncrypt Lib "advapi32.dll" ( _
ByVal hKey As Long, _
ByVal hHash As Long, _
ByVal Final As Long, _
ByVal dwFlags As Long, _
pbData As Any, _
ByRef pdwDataLen As Long, _
ByVal dwBufLen As Long) As Long Private Declare Function CryptDecrypt Lib "advapi32.dll" ( _
ByVal hKey As Long, _
ByVal hHash As Long, _
ByVal Final As Long, _
ByVal dwFlags As Long, _
pbData As Any, _
ByRef pdwDataLen As Long) As Long Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Dest As Any, _
Src As Any, _
ByVal Ln As Long) Private Const PROV_RSA_FULL = Private Const CRYPT_NEWKEYSET = &H8 Private Const ALG_CLASS_HASH =
Private Const ALG_CLASS_DATA_ENCRYPT = & Private Const ALG_TYPE_ANY =
Private Const ALG_TYPE_BLOCK = &
Private Const ALG_TYPE_STREAM = & Private Const ALG_SID_MD2 =
Private Const ALG_SID_MD4 =
Private Const ALG_SID_MD5 =
Private Const ALG_SID_SHA1 = Private Const ALG_SID_DES =
Private Const ALG_SID_3DES =
Private Const ALG_SID_RC2 =
Private Const ALG_SID_RC4 =
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
Enum ENCALGORITHM
DES = ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_DES
[3DES] = ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_3DES
RC2 = ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_RC2
RC4 = ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM Or ALG_SID_RC4
End Enum Dim HexMatrix(, ) As Byte
'================================================
'加密
'================================================
Public Function EncryptString(ByVal str As String, password As String) As String
Dim byt() As Byte
Dim HASHALGORITHM As HASHALGORITHM
Dim ENCALGORITHM As ENCALGORITHM
byt = str
HASHALGORITHM = MD5
ENCALGORITHM = RC4
EncryptString = BytesToHex(Encrypt(byt, password, HASHALGORITHM, ENCALGORITHM))
End Function
Public Function EncryptByte(byt() As Byte, password As String) As Byte()
Dim HASHALGORITHM As HASHALGORITHM
Dim ENCALGORITHM As ENCALGORITHM
HASHALGORITHM = MD5
ENCALGORITHM = RC4
EncryptByte = Encrypt(byt, password, HASHALGORITHM, ENCALGORITHM)
End Function
Private Function Encrypt(data() As Byte, ByVal password As String, Optional ByVal HASHALGORITHM As HASHALGORITHM = MD5, Optional ByVal ENCALGORITHM As ENCALGORITHM = RC4) As Byte()
Dim lRes As Long
Dim hProv As Long
Dim hHash As Long
Dim hKey As Long
Dim lBufLen As Long
Dim lDataLen As Long
Dim abData() As Byte
lRes = CryptAcquireContext(hProv, vbNullString, vbNullString, PROV_RSA_FULL, )
If lRes = And Err.LastDllError = &H80090016 Then lRes = CryptAcquireContext(hProv, vbNullString, vbNullString, PROV_RSA_FULL, CRYPT_NEWKEYSET)
If lRes <> Then
lRes = CryptCreateHash(hProv, HASHALGORITHM, , , hHash)
If lRes <> Then
lRes = CryptHashData(hHash, ByVal password, Len(password), )
If lRes <> Then
lRes = CryptDeriveKey(hProv, ENCALGORITHM, hHash, , hKey)
If lRes <> Then
lBufLen = UBound(data) - LBound(data) +
lDataLen = lBufLen
lRes = CryptEncrypt(hKey, &, , , ByVal &, lBufLen, )
If lRes <> Then
If lBufLen < lDataLen Then lBufLen = lDataLen
ReDim abData( To lBufLen - )
MoveMemory abData(), data(LBound(data)), lDataLen
lRes = CryptEncrypt(hKey, &, , , abData(), lBufLen, lDataLen)
If lRes <> Then
If lDataLen <> lBufLen Then ReDim Preserve abData( To lBufLen - )
Encrypt = abData
End If
End If
End If
CryptDestroyKey hKey
End If
CryptDestroyHash hHash
End If
CryptReleaseContext hProv,
End If
If lRes = Then Err.Raise Err.LastDllError
End Function
'================================================
'解密
'================================================
Public Function DecryptString(ByVal str As String, password As String) As String
Dim byt() As Byte
Dim HASHALGORITHM As HASHALGORITHM
Dim ENCALGORITHM As ENCALGORITHM
byt = HexToBytes(str)
HASHALGORITHM = MD5
ENCALGORITHM = RC4
DecryptString = Decrypt(byt, password, HASHALGORITHM, ENCALGORITHM)
End Function
Public Function DecryptByte(byt() As Byte, password As String) As Byte()
Dim HASHALGORITHM As HASHALGORITHM
Dim ENCALGORITHM As ENCALGORITHM
HASHALGORITHM = MD5
ENCALGORITHM = RC4
DecryptByte = Decrypt(byt, password, HASHALGORITHM, ENCALGORITHM)
End Function
Private Function Decrypt(data() As Byte, ByVal password As String, Optional ByVal HASHALGORITHM As HASHALGORITHM = MD5, Optional ByVal ENCALGORITHM As ENCALGORITHM = RC4) As Byte()
Dim lRes As Long
Dim hProv As Long
Dim hHash As Long
Dim hKey As Long
Dim lBufLen As Long
Dim abData() As Byte
lRes = CryptAcquireContext(hProv, vbNullString, vbNullString, PROV_RSA_FULL, )
If lRes = And Err.LastDllError = &H80090016 Then lRes = CryptAcquireContext(hProv, vbNullString, vbNullString, PROV_RSA_FULL, CRYPT_NEWKEYSET)
If lRes <> Then
lRes = CryptCreateHash(hProv, HASHALGORITHM, , , hHash)
If lRes <> Then
lRes = CryptHashData(hHash, ByVal password, Len(password), )
If lRes <> Then
lRes = CryptDeriveKey(hProv, ENCALGORITHM, hHash, , hKey)
If lRes <> Then
lBufLen = UBound(data) - LBound(data) +
ReDim abData( To lBufLen - )
MoveMemory abData(), data(LBound(data)), lBufLen
lRes = CryptDecrypt(hKey, &, , , abData(), lBufLen)
If lRes <> Then
ReDim Preserve abData( To lBufLen - )
Decrypt = abData
End If
End If
CryptDestroyKey hKey
End If
CryptDestroyHash hHash
End If
CryptReleaseContext hProv,
End If
If lRes = Then Err.Raise Err.LastDllError
End Function '================================================
'字节与十六进制字符串的转换
'================================================
Public Function BytesToHex(bits() As Byte) As String
Dim i As Long
Dim b
Dim s As String
For Each b In bits
If b < Then
s = s & "" & Hex(b)
Else
s = s & Hex(b)
End If
Next
BytesToHex = s
End Function
Public Function HexToBytes(sHex As String) As Byte()
Dim b() As Byte
Dim rst() As Byte
Dim i As Long
Dim n As Long
Dim m1 As Byte
Dim m2 As Byte
If HexMatrix(, ) = Then Call MatrixInitialize
b = StrConv(sHex, vbFromUnicode)
i = (UBound(b) + ) / -
ReDim rst(i)
For i = To UBound(b) Step
If b(i) > Then
m1 = b(i) -
ElseIf b(i) > Then
m1 = b(i) -
ElseIf b(i) > Then
m1 = b(i) -
End If
If b(i + ) > Then
m2 = b(i + ) -
ElseIf b(i + ) > Then
m2 = b(i + ) -
ElseIf b(i + ) > Then
m2 = b(i + ) -
End If
rst(n) = HexMatrix(m1, m2)
n = n +
Next i
HexToBytes = rst
End Function
Private Sub MatrixInitialize()
HexMatrix(, ) = &H0: HexMatrix(, ) = &H1: HexMatrix(, ) = &H2: HexMatrix(, ) = &H3: HexMatrix(, ) = &H4: HexMatrix(, ) = &H5: HexMatrix(, ) = &H6: HexMatrix(, ) = &H7
HexMatrix(, ) = &H8: HexMatrix(, ) = &H9: HexMatrix(, ) = &HA: HexMatrix(, ) = &HB: HexMatrix(, ) = &HC: HexMatrix(, ) = &HD: HexMatrix(, ) = &HE: HexMatrix(, ) = &HF
HexMatrix(, ) = &H10: HexMatrix(, ) = &H11: HexMatrix(, ) = &H12: HexMatrix(, ) = &H13: HexMatrix(, ) = &H14: HexMatrix(, ) = &H15: HexMatrix(, ) = &H16: HexMatrix(, ) = &H17
HexMatrix(, ) = &H18: HexMatrix(, ) = &H19: HexMatrix(, ) = &H1A: HexMatrix(, ) = &H1B: HexMatrix(, ) = &H1C: HexMatrix(, ) = &H1D: HexMatrix(, ) = &H1E: HexMatrix(, ) = &H1F
HexMatrix(, ) = &H20: HexMatrix(, ) = &H21: HexMatrix(, ) = &H22: HexMatrix(, ) = &H23: HexMatrix(, ) = &H24: HexMatrix(, ) = &H25: HexMatrix(, ) = &H26: HexMatrix(, ) = &H27
HexMatrix(, ) = &H28: HexMatrix(, ) = &H29: HexMatrix(, ) = &H2A: HexMatrix(, ) = &H2B: HexMatrix(, ) = &H2C: HexMatrix(, ) = &H2D: HexMatrix(, ) = &H2E: HexMatrix(, ) = &H2F
HexMatrix(, ) = &H30: HexMatrix(, ) = &H31: HexMatrix(, ) = &H32: HexMatrix(, ) = &H33: HexMatrix(, ) = &H34: HexMatrix(, ) = &H35: HexMatrix(, ) = &H36: HexMatrix(, ) = &H37
HexMatrix(, ) = &H38: HexMatrix(, ) = &H39: HexMatrix(, ) = &H3A: HexMatrix(, ) = &H3B: HexMatrix(, ) = &H3C: HexMatrix(, ) = &H3D: HexMatrix(, ) = &H3E: HexMatrix(, ) = &H3F
HexMatrix(, ) = &H40: HexMatrix(, ) = &H41: HexMatrix(, ) = &H42: HexMatrix(, ) = &H43: HexMatrix(, ) = &H44: HexMatrix(, ) = &H45: HexMatrix(, ) = &H46: HexMatrix(, ) = &H47
HexMatrix(, ) = &H48: HexMatrix(, ) = &H49: HexMatrix(, ) = &H4A: HexMatrix(, ) = &H4B: HexMatrix(, ) = &H4C: HexMatrix(, ) = &H4D: HexMatrix(, ) = &H4E: HexMatrix(, ) = &H4F
HexMatrix(, ) = &H50: HexMatrix(, ) = &H51: HexMatrix(, ) = &H52: HexMatrix(, ) = &H53: HexMatrix(, ) = &H54: HexMatrix(, ) = &H55: HexMatrix(, ) = &H56: HexMatrix(, ) = &H57
HexMatrix(, ) = &H58: HexMatrix(, ) = &H59: HexMatrix(, ) = &H5A: HexMatrix(, ) = &H5B: HexMatrix(, ) = &H5C: HexMatrix(, ) = &H5D: HexMatrix(, ) = &H5E: HexMatrix(, ) = &H5F
HexMatrix(, ) = &H60: HexMatrix(, ) = &H61: HexMatrix(, ) = &H62: HexMatrix(, ) = &H63: HexMatrix(, ) = &H64: HexMatrix(, ) = &H65: HexMatrix(, ) = &H66: HexMatrix(, ) = &H67
HexMatrix(, ) = &H68: HexMatrix(, ) = &H69: HexMatrix(, ) = &H6A: HexMatrix(, ) = &H6B: HexMatrix(, ) = &H6C: HexMatrix(, ) = &H6D: HexMatrix(, ) = &H6E: HexMatrix(, ) = &H6F
HexMatrix(, ) = &H70: HexMatrix(, ) = &H71: HexMatrix(, ) = &H72: HexMatrix(, ) = &H73: HexMatrix(, ) = &H74: HexMatrix(, ) = &H75: HexMatrix(, ) = &H76: HexMatrix(, ) = &H77
HexMatrix(, ) = &H78: HexMatrix(, ) = &H79: HexMatrix(, ) = &H7A: HexMatrix(, ) = &H7B: HexMatrix(, ) = &H7C: HexMatrix(, ) = &H7D: HexMatrix(, ) = &H7E: HexMatrix(, ) = &H7F
HexMatrix(, ) = &H80: HexMatrix(, ) = &H81: HexMatrix(, ) = &H82: HexMatrix(, ) = &H83: HexMatrix(, ) = &H84: HexMatrix(, ) = &H85: HexMatrix(, ) = &H86: HexMatrix(, ) = &H87
HexMatrix(, ) = &H88: HexMatrix(, ) = &H89: HexMatrix(, ) = &H8A: HexMatrix(, ) = &H8B: HexMatrix(, ) = &H8C: HexMatrix(, ) = &H8D: HexMatrix(, ) = &H8E: HexMatrix(, ) = &H8F
HexMatrix(, ) = &H90: HexMatrix(, ) = &H91: HexMatrix(, ) = &H92: HexMatrix(, ) = &H93: HexMatrix(, ) = &H94: HexMatrix(, ) = &H95: HexMatrix(, ) = &H96: HexMatrix(, ) = &H97
HexMatrix(, ) = &H98: HexMatrix(, ) = &H99: HexMatrix(, ) = &H9A: HexMatrix(, ) = &H9B: HexMatrix(, ) = &H9C: HexMatrix(, ) = &H9D: HexMatrix(, ) = &H9E: HexMatrix(, ) = &H9F
HexMatrix(, ) = &HA0: HexMatrix(, ) = &HA1: HexMatrix(, ) = &HA2: HexMatrix(, ) = &HA3: HexMatrix(, ) = &HA4: HexMatrix(, ) = &HA5: HexMatrix(, ) = &HA6: HexMatrix(, ) = &HA7
HexMatrix(, ) = &HA8: HexMatrix(, ) = &HA9: HexMatrix(, ) = &HAA: HexMatrix(, ) = &HAB: HexMatrix(, ) = &HAC: HexMatrix(, ) = &HAD: HexMatrix(, ) = &HAE: HexMatrix(, ) = &HAF
HexMatrix(, ) = &HB0: HexMatrix(, ) = &HB1: HexMatrix(, ) = &HB2: HexMatrix(, ) = &HB3: HexMatrix(, ) = &HB4: HexMatrix(, ) = &HB5: HexMatrix(, ) = &HB6: HexMatrix(, ) = &HB7
HexMatrix(, ) = &HB8: HexMatrix(, ) = &HB9: HexMatrix(, ) = &HBA: HexMatrix(, ) = &HBB: HexMatrix(, ) = &HBC: HexMatrix(, ) = &HBD: HexMatrix(, ) = &HBE: HexMatrix(, ) = &HBF
HexMatrix(, ) = &HC0: HexMatrix(, ) = &HC1: HexMatrix(, ) = &HC2: HexMatrix(, ) = &HC3: HexMatrix(, ) = &HC4: HexMatrix(, ) = &HC5: HexMatrix(, ) = &HC6: HexMatrix(, ) = &HC7
HexMatrix(, ) = &HC8: HexMatrix(, ) = &HC9: HexMatrix(, ) = &HCA: HexMatrix(, ) = &HCB: HexMatrix(, ) = &HCC: HexMatrix(, ) = &HCD: HexMatrix(, ) = &HCE: HexMatrix(, ) = &HCF
HexMatrix(, ) = &HD0: HexMatrix(, ) = &HD1: HexMatrix(, ) = &HD2: HexMatrix(, ) = &HD3: HexMatrix(, ) = &HD4: HexMatrix(, ) = &HD5: HexMatrix(, ) = &HD6: HexMatrix(, ) = &HD7
HexMatrix(, ) = &HD8: HexMatrix(, ) = &HD9: HexMatrix(, ) = &HDA: HexMatrix(, ) = &HDB: HexMatrix(, ) = &HDC: HexMatrix(, ) = &HDD: HexMatrix(, ) = &HDE: HexMatrix(, ) = &HDF
HexMatrix(, ) = &HE0: HexMatrix(, ) = &HE1: HexMatrix(, ) = &HE2: HexMatrix(, ) = &HE3: HexMatrix(, ) = &HE4: HexMatrix(, ) = &HE5: HexMatrix(, ) = &HE6: HexMatrix(, ) = &HE7
HexMatrix(, ) = &HE8: HexMatrix(, ) = &HE9: HexMatrix(, ) = &HEA: HexMatrix(, ) = &HEB: HexMatrix(, ) = &HEC: HexMatrix(, ) = &HED: HexMatrix(, ) = &HEE: HexMatrix(, ) = &HEF
HexMatrix(, ) = &HF0: HexMatrix(, ) = &HF1: HexMatrix(, ) = &HF2: HexMatrix(, ) = &HF3: HexMatrix(, ) = &HF4: HexMatrix(, ) = &HF5: HexMatrix(, ) = &HF6: HexMatrix(, ) = &HF7
HexMatrix(, ) = &HF8: HexMatrix(, ) = &HF9: HexMatrix(, ) = &HFA: HexMatrix(, ) = &HFB: HexMatrix(, ) = &HFC: HexMatrix(, ) = &HFD: HexMatrix(, ) = &HFE: HexMatrix(, ) = &HFF
End Sub
测试代码:
Private Sub Command1_Click()
Dim bs() As Byte, be() As Byte, bd() As Byte
bs = StrConv("", vbFromUnicode)
be = EncryptByte(bs, "password")
bd = DecryptByte(be, "password")
Dim s1 As String, s2 As String, s3 As String
s1 = BytesToHex(bs)
s2 = BytesToHex(be)
s3 = BytesToHex(bd)
Print "原始字节:" & s1 & " (len:" & Len(s1) / & ")"
Print "加密字节:" & s2 & " (len:" & Len(s2) & ")"
Print "解密字节:" & s3 & " (len:" & Len(s3) & ")"
Print "--------------------------------"
Dim ss As String, se As String, sd As String
ss = "MD5加/解密"
se = EncryptString(ss, "password")
sd = DecryptString(se, "password")
Print "原文:" & ss & " (len:" & LenB(ss) & ")"
Print "加密:" & se & " (len:" & Len(se) & ")"
Print "解密:" & sd & " (len:" & LenB(sd) & ")"
End Sub
