根据网络资料整改,来源未知,已调试通过.
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 = 1 Private Const CRYPT_NEWKEYSET = &H8 Private Const ALG_CLASS_HASH = 32768 Private Const ALG_CLASS_DATA_ENCRYPT = 24576& Private Const ALG_TYPE_ANY = 0 Private Const ALG_TYPE_BLOCK = 1536& Private Const ALG_TYPE_STREAM = 2048& Private Const ALG_SID_MD2 = 1 Private Const ALG_SID_MD4 = 2 Private Const ALG_SID_MD5 = 3 Private Const ALG_SID_SHA1 = 4 Private Const ALG_SID_DES = 1 Private Const ALG_SID_3DES = 3 Private Const ALG_SID_RC2 = 2 Private Const ALG_SID_RC4 = 1 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(15, 15) 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, 0) If lRes = 0 And Err.LastDllError = &H80090016 Then lRes = CryptAcquireContext(hProv, vbNullString, vbNullString, PROV_RSA_FULL, CRYPT_NEWKEYSET) If lRes <> 0 Then lRes = CryptCreateHash(hProv, HASHALGORITHM, 0, 0, hHash) If lRes <> 0 Then lRes = CryptHashData(hHash, ByVal password, Len(password), 0) If lRes <> 0 Then lRes = CryptDeriveKey(hProv, ENCALGORITHM, hHash, 0, hKey) If lRes <> 0 Then lBufLen = UBound(data) - LBound(data) + 1 lDataLen = lBufLen lRes = CryptEncrypt(hKey, 0&, 1, 0, ByVal 0&, lBufLen, 0) If lRes <> 0 Then If lBufLen < lDataLen Then lBufLen = lDataLen ReDim abData(0 To lBufLen - 1) MoveMemory abData(0), data(LBound(data)), lDataLen lRes = CryptEncrypt(hKey, 0&, 1, 0, abData(0), lBufLen, lDataLen) If lRes <> 0 Then If lDataLen <> lBufLen Then ReDim Preserve abData(0 To lBufLen - 1) Encrypt = abData End If End If End If CryptDestroyKey hKey End If CryptDestroyHash hHash End If CryptReleaseContext hProv, 0 End If If lRes = 0 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, 0) If lRes = 0 And Err.LastDllError = &H80090016 Then lRes = CryptAcquireContext(hProv, vbNullString, vbNullString, PROV_RSA_FULL, CRYPT_NEWKEYSET) If lRes <> 0 Then lRes = CryptCreateHash(hProv, HASHALGORITHM, 0, 0, hHash) If lRes <> 0 Then lRes = CryptHashData(hHash, ByVal password, Len(password), 0) If lRes <> 0 Then lRes = CryptDeriveKey(hProv, ENCALGORITHM, hHash, 0, hKey) If lRes <> 0 Then lBufLen = UBound(data) - LBound(data) + 1 ReDim abData(0 To lBufLen - 1) MoveMemory abData(0), data(LBound(data)), lBufLen lRes = CryptDecrypt(hKey, 0&, 1, 0, abData(0), lBufLen) If lRes <> 0 Then ReDim Preserve abData(0 To lBufLen - 1) Decrypt = abData End If End If CryptDestroyKey hKey End If CryptDestroyHash hHash End If CryptReleaseContext hProv, 0 End If If lRes = 0 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 < 16 Then s = s & "0" & 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(15, 15) = 0 Then Call MatrixInitialize b = StrConv(sHex, vbFromUnicode) i = (UBound(b) + 1) / 2 - 1 ReDim rst(i) For i = 0 To UBound(b) Step 2 If b(i) > 96 Then m1 = b(i) - 87 ElseIf b(i) > 64 Then m1 = b(i) - 55 ElseIf b(i) > 47 Then m1 = b(i) - 48 End If If b(i + 1) > 96 Then m2 = b(i + 1) - 87 ElseIf b(i + 1) > 64 Then m2 = b(i + 1) - 55 ElseIf b(i + 1) > 47 Then m2 = b(i + 1) - 48 End If rst(n) = HexMatrix(m1, m2) n = n + 1 Next i HexToBytes = rst End Function Private Sub MatrixInitialize() HexMatrix(0, 0) = &H0: HexMatrix(0, 1) = &H1: HexMatrix(0, 2) = &H2: HexMatrix(0, 3) = &H3: HexMatrix(0, 4) = &H4: HexMatrix(0, 5) = &H5: HexMatrix(0, 6) = &H6: HexMatrix(0, 7) = &H7 HexMatrix(0, 8) = &H8: HexMatrix(0, 9) = &H9: HexMatrix(0, 10) = &HA: HexMatrix(0, 11) = &HB: HexMatrix(0, 12) = &HC: HexMatrix(0, 13) = &HD: HexMatrix(0, 14) = &HE: HexMatrix(0, 15) = &HF HexMatrix(1, 0) = &H10: HexMatrix(1, 1) = &H11: HexMatrix(1, 2) = &H12: HexMatrix(1, 3) = &H13: HexMatrix(1, 4) = &H14: HexMatrix(1, 5) = &H15: HexMatrix(1, 6) = &H16: HexMatrix(1, 7) = &H17 HexMatrix(1, 8) = &H18: HexMatrix(1, 9) = &H19: HexMatrix(1, 10) = &H1A: HexMatrix(1, 11) = &H1B: HexMatrix(1, 12) = &H1C: HexMatrix(1, 13) = &H1D: HexMatrix(1, 14) = &H1E: HexMatrix(1, 15) = &H1F HexMatrix(2, 0) = &H20: HexMatrix(2, 1) = &H21: HexMatrix(2, 2) = &H22: HexMatrix(2, 3) = &H23: HexMatrix(2, 4) = &H24: HexMatrix(2, 5) = &H25: HexMatrix(2, 6) = &H26: HexMatrix(2, 7) = &H27 HexMatrix(2, 8) = &H28: HexMatrix(2, 9) = &H29: HexMatrix(2, 10) = &H2A: HexMatrix(2, 11) = &H2B: HexMatrix(2, 12) = &H2C: HexMatrix(2, 13) = &H2D: HexMatrix(2, 14) = &H2E: HexMatrix(2, 15) = &H2F HexMatrix(3, 0) = &H30: HexMatrix(3, 1) = &H31: HexMatrix(3, 2) = &H32: HexMatrix(3, 3) = &H33: HexMatrix(3, 4) = &H34: HexMatrix(3, 5) = &H35: HexMatrix(3, 6) = &H36: HexMatrix(3, 7) = &H37 HexMatrix(3, 8) = &H38: HexMatrix(3, 9) = &H39: HexMatrix(3, 10) = &H3A: HexMatrix(3, 11) = &H3B: HexMatrix(3, 12) = &H3C: HexMatrix(3, 13) = &H3D: HexMatrix(3, 14) = &H3E: HexMatrix(3, 15) = &H3F HexMatrix(4, 0) = &H40: HexMatrix(4, 1) = &H41: HexMatrix(4, 2) = &H42: HexMatrix(4, 3) = &H43: HexMatrix(4, 4) = &H44: HexMatrix(4, 5) = &H45: HexMatrix(4, 6) = &H46: HexMatrix(4, 7) = &H47 HexMatrix(4, 8) = &H48: HexMatrix(4, 9) = &H49: HexMatrix(4, 10) = &H4A: HexMatrix(4, 11) = &H4B: HexMatrix(4, 12) = &H4C: HexMatrix(4, 13) = &H4D: HexMatrix(4, 14) = &H4E: HexMatrix(4, 15) = &H4F HexMatrix(5, 0) = &H50: HexMatrix(5, 1) = &H51: HexMatrix(5, 2) = &H52: HexMatrix(5, 3) = &H53: HexMatrix(5, 4) = &H54: HexMatrix(5, 5) = &H55: HexMatrix(5, 6) = &H56: HexMatrix(5, 7) = &H57 HexMatrix(5, 8) = &H58: HexMatrix(5, 9) = &H59: HexMatrix(5, 10) = &H5A: HexMatrix(5, 11) = &H5B: HexMatrix(5, 12) = &H5C: HexMatrix(5, 13) = &H5D: HexMatrix(5, 14) = &H5E: HexMatrix(5, 15) = &H5F HexMatrix(6, 0) = &H60: HexMatrix(6, 1) = &H61: HexMatrix(6, 2) = &H62: HexMatrix(6, 3) = &H63: HexMatrix(6, 4) = &H64: HexMatrix(6, 5) = &H65: HexMatrix(6, 6) = &H66: HexMatrix(6, 7) = &H67 HexMatrix(6, 8) = &H68: HexMatrix(6, 9) = &H69: HexMatrix(6, 10) = &H6A: HexMatrix(6, 11) = &H6B: HexMatrix(6, 12) = &H6C: HexMatrix(6, 13) = &H6D: HexMatrix(6, 14) = &H6E: HexMatrix(6, 15) = &H6F HexMatrix(7, 0) = &H70: HexMatrix(7, 1) = &H71: HexMatrix(7, 2) = &H72: HexMatrix(7, 3) = &H73: HexMatrix(7, 4) = &H74: HexMatrix(7, 5) = &H75: HexMatrix(7, 6) = &H76: HexMatrix(7, 7) = &H77 HexMatrix(7, 8) = &H78: HexMatrix(7, 9) = &H79: HexMatrix(7, 10) = &H7A: HexMatrix(7, 11) = &H7B: HexMatrix(7, 12) = &H7C: HexMatrix(7, 13) = &H7D: HexMatrix(7, 14) = &H7E: HexMatrix(7, 15) = &H7F HexMatrix(8, 0) = &H80: HexMatrix(8, 1) = &H81: HexMatrix(8, 2) = &H82: HexMatrix(8, 3) = &H83: HexMatrix(8, 4) = &H84: HexMatrix(8, 5) = &H85: HexMatrix(8, 6) = &H86: HexMatrix(8, 7) = &H87 HexMatrix(8, 8) = &H88: HexMatrix(8, 9) = &H89: HexMatrix(8, 10) = &H8A: HexMatrix(8, 11) = &H8B: HexMatrix(8, 12) = &H8C: HexMatrix(8, 13) = &H8D: HexMatrix(8, 14) = &H8E: HexMatrix(8, 15) = &H8F HexMatrix(9, 0) = &H90: HexMatrix(9, 1) = &H91: HexMatrix(9, 2) = &H92: HexMatrix(9, 3) = &H93: HexMatrix(9, 4) = &H94: HexMatrix(9, 5) = &H95: HexMatrix(9, 6) = &H96: HexMatrix(9, 7) = &H97 HexMatrix(9, 8) = &H98: HexMatrix(9, 9) = &H99: HexMatrix(9, 10) = &H9A: HexMatrix(9, 11) = &H9B: HexMatrix(9, 12) = &H9C: HexMatrix(9, 13) = &H9D: HexMatrix(9, 14) = &H9E: HexMatrix(9, 15) = &H9F HexMatrix(10, 0) = &HA0: HexMatrix(10, 1) = &HA1: HexMatrix(10, 2) = &HA2: HexMatrix(10, 3) = &HA3: HexMatrix(10, 4) = &HA4: HexMatrix(10, 5) = &HA5: HexMatrix(10, 6) = &HA6: HexMatrix(10, 7) = &HA7 HexMatrix(10, 8) = &HA8: HexMatrix(10, 9) = &HA9: HexMatrix(10, 10) = &HAA: HexMatrix(10, 11) = &HAB: HexMatrix(10, 12) = &HAC: HexMatrix(10, 13) = &HAD: HexMatrix(10, 14) = &HAE: HexMatrix(10, 15) = &HAF HexMatrix(11, 0) = &HB0: HexMatrix(11, 1) = &HB1: HexMatrix(11, 2) = &HB2: HexMatrix(11, 3) = &HB3: HexMatrix(11, 4) = &HB4: HexMatrix(11, 5) = &HB5: HexMatrix(11, 6) = &HB6: HexMatrix(11, 7) = &HB7 HexMatrix(11, 8) = &HB8: HexMatrix(11, 9) = &HB9: HexMatrix(11, 10) = &HBA: HexMatrix(11, 11) = &HBB: HexMatrix(11, 12) = &HBC: HexMatrix(11, 13) = &HBD: HexMatrix(11, 14) = &HBE: HexMatrix(11, 15) = &HBF HexMatrix(12, 0) = &HC0: HexMatrix(12, 1) = &HC1: HexMatrix(12, 2) = &HC2: HexMatrix(12, 3) = &HC3: HexMatrix(12, 4) = &HC4: HexMatrix(12, 5) = &HC5: HexMatrix(12, 6) = &HC6: HexMatrix(12, 7) = &HC7 HexMatrix(12, 8) = &HC8: HexMatrix(12, 9) = &HC9: HexMatrix(12, 10) = &HCA: HexMatrix(12, 11) = &HCB: HexMatrix(12, 12) = &HCC: HexMatrix(12, 13) = &HCD: HexMatrix(12, 14) = &HCE: HexMatrix(12, 15) = &HCF HexMatrix(13, 0) = &HD0: HexMatrix(13, 1) = &HD1: HexMatrix(13, 2) = &HD2: HexMatrix(13, 3) = &HD3: HexMatrix(13, 4) = &HD4: HexMatrix(13, 5) = &HD5: HexMatrix(13, 6) = &HD6: HexMatrix(13, 7) = &HD7 HexMatrix(13, 8) = &HD8: HexMatrix(13, 9) = &HD9: HexMatrix(13, 10) = &HDA: HexMatrix(13, 11) = &HDB: HexMatrix(13, 12) = &HDC: HexMatrix(13, 13) = &HDD: HexMatrix(13, 14) = &HDE: HexMatrix(13, 15) = &HDF HexMatrix(14, 0) = &HE0: HexMatrix(14, 1) = &HE1: HexMatrix(14, 2) = &HE2: HexMatrix(14, 3) = &HE3: HexMatrix(14, 4) = &HE4: HexMatrix(14, 5) = &HE5: HexMatrix(14, 6) = &HE6: HexMatrix(14, 7) = &HE7 HexMatrix(14, 8) = &HE8: HexMatrix(14, 9) = &HE9: HexMatrix(14, 10) = &HEA: HexMatrix(14, 11) = &HEB: HexMatrix(14, 12) = &HEC: HexMatrix(14, 13) = &HED: HexMatrix(14, 14) = &HEE: HexMatrix(14, 15) = &HEF HexMatrix(15, 0) = &HF0: HexMatrix(15, 1) = &HF1: HexMatrix(15, 2) = &HF2: HexMatrix(15, 3) = &HF3: HexMatrix(15, 4) = &HF4: HexMatrix(15, 5) = &HF5: HexMatrix(15, 6) = &HF6: HexMatrix(15, 7) = &HF7 HexMatrix(15, 8) = &HF8: HexMatrix(15, 9) = &HF9: HexMatrix(15, 10) = &HFA: HexMatrix(15, 11) = &HFB: HexMatrix(15, 12) = &HFC: HexMatrix(15, 13) = &HFD: HexMatrix(15, 14) = &HFE: HexMatrix(15, 15) = &HFF End Sub
测试代码:
Private Sub Command1_Click() Dim bs() As Byte, be() As Byte, bd() As Byte bs = StrConv("0123456789", 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) / 2 & ")" 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
