VB-Base64 文件或字符加解密

先引用：Scriping.runtime

Option Explicit Private Const BASE64CHR As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" Private psBase64Chr(0 To 63) As String '从一个经过Base64的字符串中解码到源字符串 Public Function DecodeBase64String(str2Decode As String) As String DecodeBase64String = StrConv(DecodeBase64Byte(str2Decode),vbUnicode) End Function '从一个经过Base64的字符串中解码到源字节数组 Public Function DecodeBase64Byte(str2Decode As String) As Byte() Dim lPtr As Long Dim iValue As Integer Dim iLen As Integer Dim iCtr As Integer Dim Bits(1 To 4) As Byte Dim strDecode As String Dim str As String Dim Output() As Byte Dim iIndex As Long Dim lFrom As Long Dim lTo As Long InitBase '//除去回车 str = Replace(str2Decode,vbCrLf,"") '//每4个字符一组（4个字符表示3个字） For lPtr = 1 To Len(str) Step 4 iLen = 4 For iCtr = 0 To 3 '//查找字符在BASE64字符串中的位置 iValue = InStr(1,BASE64CHR,Mid$(str,lPtr + iCtr,1),vbBinaryCompare) Select Case iValue 'A~Za~z0~9+/ Case 1 To 64: Bits(iCtr + 1) = iValue - 1 Case 65 '= iLen = iCtr Exit For '//没有发现 Case 0: Exit Function End Select Next '//转换4个6比特数成为3个8比特数 Bits(1) = Bits(1) * &H4 + (Bits(2) And &H30) / &H10 Bits(2) = (Bits(2) And &HF) * &H10 + (Bits(3) And &H3C) / &H4 Bits(3) = (Bits(3) And &H3) * &H40 + Bits(4) '//计算数组的起始位置 lFrom = lTo lTo = lTo + (iLen - 1) - 1 '//重新定义输出数组 ReDim Preserve Output(0 To lTo) For iIndex = lFrom To lTo Output(iIndex) = Bits(iIndex - lFrom + 1) Next lTo = lTo + 1 Next DecodeBase64Byte = Output End Function '将一个Base64字符串解码，并写入二进制文件 Public Sub DecodeBase64StringToFile(strBase64 As String,strFilePath As String) Dim fso As New Scripting.FileSystemObject,_ i As Long If fso.FileExists(strFilePath) Then fso.DeleteFile strFilePath,True End If i = FreeFile Open strFilePath For Binary Access Write As i Put i,DecodeBase64Byte(strBase64) Close i Set fso = Nothing End Sub '将一个Base64编码文件解码，并写入二进制文件 Public Sub DecodeBase64FileToFile(strBase64FilePath As String,strFilePath As String) Dim fso As New Scripting.FileSystemObject Dim ts As TextStream If Not fso.FileExists(strBase64FilePath) Then Exit Sub Set ts = fso.OpenTextFile(strBase64FilePath) DecodeBase64StringToFile ts.ReadAll,strFilePath End Sub '将一个字节数组进行Base64编码，并返回字符串 Public Function EncodeBase64Byte(sValue() As Byte) As String Dim lCtr As Long Dim lPtr As Long Dim lLen As Long Dim sEncoded As String Dim Bits8(1 To 3) As Byte Dim Bits6(1 To 4) As Byte Dim i As Integer InitBase For lCtr = 1 To UBound(sValue) + 1 Step 3 For i = 1 To 3 If lCtr + i - 2 <= UBound(sValue) Then Bits8(i) = sValue(lCtr + i - 2) lLen = 3 Else Bits8(i) = 0 lLen = lLen - 1 End If Next '//转换字符串为数组，然后转换为4个6位(0-63) Bits6(1) = (Bits8(1) And &HFC) / 4 Bits6(2) = (Bits8(1) And &H3) * &H10 + (Bits8(2) And &HF0) / &H10 Bits6(3) = (Bits8(2) And &HF) * 4 + (Bits8(3) And &HC0) / &H40 Bits6(4) = Bits8(3) And &H3F '//添加4个新字符 For lPtr = 1 To lLen + 1 sEncoded = sEncoded & psBase64Chr(Bits6(lPtr)) Next Next '//不足4位，以=填充 Select Case lLen + 1 Case 2: sEncoded = sEncoded & "==" Case 3: sEncoded = sEncoded & "=" Case 4: End Select EncodeBase64Byte = sEncoded End Function '对字符串进行Base64编码并返回字符串 Public Function EncodeBase64String(str2Encode As String) As String Dim sValue() As Byte sValue = StrConv(str2Encode,vbFromUnicode) EncodeBase64String = EncodeBase64Byte(sValue) End Function '对文件进行Base64编码并返回编码后的Base64字符串 Public Function EncodFileToBase64String(strFileSource As String) Dim lpdata() As Byte,_ i As Long,_ n As Long,_ fso As New Scripting.FileSystemObject If Not fso.FileExists(strFileSource) Then Exit Function i = FreeFile Open strFileSource For Binary Access Read Lock Write As i n = LOF(i) - 1 ReDim lpdata(0 To n) Get i,lpdata Close i EncodFileToBase64String = EncodeBase64Byte(lpdata) End Function '对文件进行Base64编码，并将编码后的内容直接写入一个文本文件中 Public Sub EncodFileToBase64File(strFileSource As String,strFileBase64Desti As String) Dim fso As New FileSystemObject,_ ts As TextStream Set ts = fso.CreateTextFile(strFileBase64Desti,True) ts.Write (EncodFileToBase64String(strFileSource)) ts.Close Set ts = Nothing Set fso = Nothing End Sub Private Sub InitBase() Dim iPtr As Integer '初始化 BASE64数组 For iPtr = 0 To 63 psBase64Chr(iPtr) = Mid$(BASE64CHR,iPtr + 1,1) Next End Sub

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!