编码代码是在原来别人写的一段代码改的
'加密进输入的字节，所以就可以加密二制文件等，返回的是一Ba64的字符串
Function B64E(inData() As Byte) As String
On Error Resume Next
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim UB As Long, lB As Long '数组的上限和下限
Dim sOut, cOut, i
Dim nGroup As Long
Dim pOut, sGroup
UB = UBound(inData)
Dim Second As Byte
Dim Thrid As Byte
lB = LBound(inData)
If Err.Number <> 0 Then
B64E = ""
Exit Function
End If
For i = lB To UB Step 3
If i + 1 > UB Then
Second = 0
Thrid = 0
ElseIf i + 2 > UB Then
Second = inData(i + 1)
Thrid = 0
Else
Second = inData(i + 1)
Thrid = inData(i + 2)
End If
nGroup = &H10000 * inData(i) + &H100 * Second + Thrid
sGroup = Oct(nGroup)
sGroup = String(8 - Len(sGroup), "0") + sGroup
pOut = Mid(Base64, CLng("&o" + Mid(sGroup, 1, 2)) + 1, 1) + Mid(Base64, CLng("&o" + Mid(sGroup, 3, 2)) + 1, 1) + Mid(Base64, CLng("&o" + Mid(sGroup, 5, 2)) + 1, 1) + Mid(Base64, CLng("&o" + Mid(sGroup, 7, 2)) + 1, 1)
sOut = sOut + pOut
If (i + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
nGroup = 0
Next i
Select Case (UB - lB + 1) Mod 3
Case 1
sOut = Left(sOut, Len(sOut) - 2) + "=="
Case 2
sOut = Left(sOut, Len(sOut) - 1) + "="
End Select
B64E = sOut
End Function
'返回的也是一字节数组
Public Function B64U(ByVal inData As String, OutData() As Byte) As Boolean
On Error GoTo Errhandle
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim UB As Long, lB As Long '数组的上限和下限
Dim sOut, cOut, i
Dim nGroup As Long
Dim pOut, sGroup
inData = Replace(inData, vbCrLf, "")
ReDim OutData(0 To (Int(Len(inData) / 4) + 1) * 3 - 1) As Byte
For i = 1 To (Len(inData) - Len(inData) Mod 4) Step 4
nGroup = &O1000000 * (InStr(Base64, Mid(inData, i, 1)) - 1) + &O10000 * (InStr(Base64, Mid(inData, i + 1, 1)) - 1) + _
&O100 * (IIf(InStr(Base64, Mid(inData, i + 2, 1)) = 0, 1, InStr(Base64, Mid(inData, i + 2, 1))) - 1) _
+ (IIf(InStr(Base64, Mid(inData, i + 3, 1)) = 0, 1, InStr(Base64, Mid(inData, i + 3, 1))) - 1)
sGroup = Trim(Hex(nGroup)) '转成16位的
sGroup = String(6 - Len(sGroup), "0") & sGroup '如果不够六位用0去补
OutData(Int(i / 4) * 3) = Val("&H" & Mid(sGroup, 1, 2))
OutData(Int(i / 4) * 3 + 1) = Val("&H" & Mid(sGroup, 3, 2))
OutData(Int(i / 4) * 3 + 2) = Val("&H" & Mid(sGroup, 5, 2))
Next i
Select Case Len(inData) - Len(Replace(inData, "=", ""))
Case 1
ReDim Preserve OutData(0 To (Int(Len(inData) / 4) + 1) * 3 - 2) As Byte
Case 2
ReDim Preserve OutData(0 To (Int(Len(inData) / 4) + 1) * 3 - 3) As Byte
End Select
B64U = True
Exit Function
Errhandle:
B64U = False
End Function
'这段代码可以加密二进制数据，像图片文件等都没有问题，
调用方法：
Private Sub Command1_Click()
Dim arrstr() As Byte
arrstr = StrConv(Text1.Text, vbFromUnicode)
Text2.Text = B64E(arrstr)
End Sub
Private Sub Command2_Click()
Dim OutData() As Byte
If B64U(Text2.Text, OutData) = True Then
Text1.Text = CStr(OutData)
End If
End Sub
|
本类阅读TOP10