qq_33967085 于 2016.03.21 22:45 提问

vb加密函数，可加密中文，有密码

3个回答

caozhy      2016.03.21 23:05

caozhy      2016.03.22 17:18
`````` Option Explicit
Private Const cstBase64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Private arrBase64() As String

Public Function 加密(strSource As String, key As String) As String
On Error Resume Next
If UBound(arrBase64) = -1 Then
arrBase64 = Split(StrConv(cstBase64, vbUnicode), vbNullChar)
End If
Dim arrB() As Byte, bTmp(2) As Byte, bT As Byte
Dim I As Long, J As Long
arrB = StrConv(strSource, vbFromUnicode)

J = UBound(arrB)
For I = 0 To J Step 3
Erase bTmp
bTmp(0) = arrB(I + 0) Xor (Asc(Mid(key, I \ 3 Mod Len(key) + 1, 1)) Mod 256)
bTmp(1) = arrB(I + 1) Xor (Asc(Mid(key, I \ 3 Mod Len(key) + 1, 1)) Mod 256)
bTmp(2) = arrB(I + 2) Xor (Asc(Mid(key, I \ 3 Mod Len(key) + 1, 1)) Mod 256)

bT = (bTmp(0) And 252) / 4
加密 = 加密 & arrBase64(bT)

bT = (bTmp(0) And 3) * 16
bT = bT + bTmp(1) \ 16
加密 = 加密 & arrBase64(bT)

bT = (bTmp(1) And 15) * 4
bT = bT + bTmp(2) \ 64
If I + 1 <= J Then
加密 = 加密 & arrBase64(bT)
Else
加密 = 加密 & "="
End If

bT = bTmp(2) And 63
If I + 2 <= J Then
加密 = 加密 & arrBase64(bT)
Else
加密 = 加密 & "="
End If
Next
End Function

Public Function 解密(strEncoded As String, key As String) As String
On Error Resume Next
Dim arrB() As Byte, bTmp(3) As Byte, bT As Long, bRet() As Byte
Dim I As Long, J As Long
arrB = StrConv(strEncoded, vbFromUnicode)
J = InStr(strEncoded & "=", "=") - 2
ReDim bRet(J - J \ 4 - 1)
For I = 0 To J Step 4
Erase bTmp
bTmp(0) = ((InStr(cstBase64, Chr(arrB(I))) - 1) And 63)
bTmp(1) = ((InStr(cstBase64, Chr(arrB(I + 1))) - 1) And 63)
bTmp(2) = ((InStr(cstBase64, Chr(arrB(I + 2))) - 1) And 63)
bTmp(3) = ((InStr(cstBase64, Chr(arrB(I + 3))) - 1) And 63)

bT = bTmp(0) * 2 ^ 18 + bTmp(1) * 2 ^ 12 + bTmp(2) * 2 ^ 6 + bTmp(3)

bRet((I \ 4) * 3) = (bT \ 65536) Xor (Asc(Mid(key, I \ 3 Mod Len(key) + 1, 1)) Mod 256)
bRet((I \ 4) * 3 + 1) = ((bT And 65280) \ 256) Xor (Asc(Mid(key, I \ 3 Mod Len(key) + 1, 1)) Mod 256)
bRet((I \ 4) * 3 + 2) = (bT And 255) Xor (Asc(Mid(key, I \ 3 Mod Len(key) + 1, 1)) Mod 256)
Next
解密 = StrConv(bRet, vbUnicode)
End Function

Private Sub Command1_Click()
Text3.Text = 加密(Text2.Text, Text1.Text)
End Sub

Private Sub Command2_Click()
Text2.Text = 解密(Text3.Text, Text1.Text)
End Sub

``````
qq_33967085 谢谢

suwu150   2016.04.07 12:55