enc64.bas

VB下对字符串（包括中文）进行base64编码和解码

Attribute VB_Name = "Enc64"
Option Explicit

Private Const BASE64CHR As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
Private psBase64Chr(0 To 63) As String


'从一个经过Base64的字符串中解码到源字符串
Public Function DecodeBase64String(str2Decode As String) As String
    On Error GoTo ErrorHandler
    DecodeBase64String = StrConv(DecodeBase64Byte(str2Decode), vbUnicode)
    Exit Function
ErrorHandler:
    DecodeBase64String = "输入的Base64码有问题"
    Resume Next
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
    Dim 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