VB Base64编解码

模块代码( m_Base64.bas):

Option Explicit
'除以2的一次方是右移一位
'乘以2的一次方是左移一位
'(bytInText(i) And &HFC)  (2 ^ 2)
'第一个字节的内容And运算0xFC(11111100)(取左边6位)，再除以2的二次方(右移2位)
'(bytInText(i) And &H3) * (2 ^ 4) Or (bytInText(i + 1) And &HF0)  (2 ^ 4)
'第一个字节的内容And运算0x03(00000011)(取右边2位)，再乘以2的四次方(左移4位)
'第二个字节的内容And运算0xF0(11110000)(取左边4位)，再除以2的四次方(右移4位)
'两个结果再Or运算
'(bytInText(i + 1) And &HF) * (2 ^ 2) + (bytInText(i + 2) And &HC0)  (2 ^ 6)
'第二个字节的内容And运算0x0F(00001111)(取右边4位)，再乘以2的二次方(左移2位)
'第三个字节的内容And运算0xC0(11000000)(取左边2位)，再除以2的六次方(右移6位)
'两个结果再Or运算
'bytInText(i + 2) And &H3F
'第三个字节的内容And运算0x3F(00111111)(取右边6位)
        
'Base64编码函数
Public Function Base64_Encode(bytInText() As Byte) As Byte()
    Dim Base64EncodeTable() As Byte
    Dim lngInTextLen As Long, lngMod As Long, i As Long
    Dim bytEncode() As Byte, lngEncodeLen As Long
    
    Base64_Encode = Chr(0)  '初始化函数返回值
    
    Base64EncodeTable() = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" '初始化Base64编码表
    Base64EncodeTable() = StrConv(Base64EncodeTable(), vbFromUnicode)  '转换为ANSI编码
    
    If LBound(bytInText) <> 0 Then Exit Function  'bytInText数组下标不从零开始则出错返回
    
    lngInTextLen = UBound(bytInText) - LBound(bytInText) + 1  '计算bytInText数组长度
    
    lngMod = lngInTextLen Mod 3 '取模3后的余数(结果只有0、1、2三种情况)
    If lngMod = 0 Then
        lngEncodeLen = lngInTextLen / 3 * 4  '求编码后的长度
        lngInTextLen = lngInTextLen / 3 * 3  '取3的整数倍
    ElseIf lngMod = 1 Then
        lngEncodeLen = (lngInTextLen + 2) / 3 * 4  '求编码后的长度
        lngInTextLen = ((lngInTextLen + 2) / 3 - 1) * 3 '取3的整数倍
    ElseIf lngMod = 2 Then
        lngEncodeLen = (lngInTextLen + 1) / 3 * 4  '求编码后的长度
        lngInTextLen = ((lngInTextLen + 1) / 3 - 1) * 3 '取3的整数倍
    End If
    
    'MsgBox "编码后的长度为" & lngEncodeLen & "字节！"
    'MsgBox "3的整数倍为" & lngInTextLen
    
    ReDim bytEncode(0 To lngEncodeLen - 1) '重新定义编码缓冲区
    lngEncodeLen = 0  '初始化编码长度计数
    
    For i = 0 To lngInTextLen - 1 Step 3
        bytEncode(lngEncodeLen) = Base64EncodeTable((bytInText(i) And &HFC)  (2 ^ 2))
        bytEncode(lngEncodeLen + 1) = Base64EncodeTable((bytInText(i) And &H3) * (2 ^ 4) Or (bytInText(i + 1) And &HF0)  (2 ^ 4))
        bytEncode(lngEncodeLen + 2) = Base64EncodeTable((bytInText(i + 1) And &HF) * (2 ^ 2) Or (bytInText(i + 2) And &HC0)  (2 ^ 6))
        bytEncode(lngEncodeLen + 3) = Base64EncodeTable(bytInText(i + 2) And &H3F)
        lngEncodeLen = lngEncodeLen + 4
    Next
    
    i = lngInTextLen - 1 + 1
    If lngMod = 1 Then  '对剩余字节进行填充
        bytEncode(lngEncodeLen) = Base64EncodeTable((bytInText(i) And &HFC)  (2 ^ 2))
        bytEncode(lngEncodeLen + 1) = Base64EncodeTable((bytInText(i) And &H3) * (2 ^ 4))
        bytEncode(lngEncodeLen + 2) = Base64EncodeTable(64)  '填充=
        bytEncode(lngEncodeLen + 3) = Base64EncodeTable(64)  '填充=
        lngEncodeLen = lngEncodeLen + 4
    ElseIf lngMod = 2 Then
        bytEncode(lngEncodeLen) = Base64EncodeTable((bytInText(i) And &HFC)  (2 ^ 2))
        bytEncode(lngEncodeLen + 1) = Base64EncodeTable((bytInText(i) And &H3) * (2 ^ 4) Or (bytInText(i + 1) And &HF0)  (2 ^ 4))
        bytEncode(lngEncodeLen + 2) = Base64EncodeTable((bytInText(i + 1) And &HF) * (2 ^ 2))
        bytEncode(lngEncodeLen + 3) = Base64EncodeTable(64)  '填充=
        lngEncodeLen = lngEncodeLen + 4
    End If

    Base64_Encode = bytEncode()
End Function

'Base64解码函数
Public Function Base64_Decode(bytInText() As Byte) As Byte()
    Dim Base64DecodeTable(1 To 122) As Byte
    Dim lngInTextLen As Long, i As Long
    Dim bytDecode() As Byte, lngDecodeLen As Long
    
    Base64_Decode = Chr(0)  '初始化函数返回值
    
    If LBound(bytInText) <> 0 Then Exit Function  'bytInText数组下标不从零开始则出错返回
    
    lngInTextLen = UBound(bytInText) - LBound(bytInText) + 1  '计算bytInText数组长度
    If lngInTextLen Mod 4 <> 0 Then Exit Function  '输入编码不是4的倍数则出错返回
    
    For i = 1 To 122  '初始化Base64解码表
        Select Case i
        Case 43  '+
            Base64DecodeTable(i) = 62
        Case 47  '/
            Base64DecodeTable(i) = 63
        Case 48 To 57  '0 - 9
            Base64DecodeTable(i) = 52 + (i - 48)
        Case 65 To 90  'A - Z
            Base64DecodeTable(i) = 0 + (i - 65)
        Case 97 To 122  'a - z
            Base64DecodeTable(i) = 26 + (i - 97)
        Case Else
            Base64DecodeTable(i) = 255
        End Select
    Next
    lngDecodeLen = lngInTextLen / 4 * 3  '求解码后的最大长度
    ReDim bytDecode(0 To lngDecodeLen - 1)  '重新定义解码缓冲区
    'MsgBox "解码后的最大长度为：" & lngDecodeLen
    
    lngDecodeLen = 0  '初始化解码长度
    
    For i = 0 To lngInTextLen - 1 Step 4
        bytDecode(lngDecodeLen) = (Base64DecodeTable(bytInText(i)) * (2 ^ 2)) Or ((Base64DecodeTable(bytInText(i + 1)) And &H30)  (2 ^ 4))
        bytDecode(lngDecodeLen + 1) = ((Base64DecodeTable(bytInText(i + 1)) And &HF) * (2 ^ 4)) Or ((Base64DecodeTable(bytInText(i + 2)) And &H3C)  (2 ^ 2))
        bytDecode(lngDecodeLen + 2) = ((Base64DecodeTable(bytInText(i + 2)) And &H3) * (2 ^ 6)) Or Base64DecodeTable(bytInText(i + 3))
        lngDecodeLen = lngDecodeLen + 3
    Next
    
    If bytInText(lngInTextLen - 1) = &H3D Then  '判断最后两个字节的情况,求解码后的实际长度
        If bytInText(lngInTextLen - 2) = &H3D Then
            lngDecodeLen = lngDecodeLen - 2  '最后两个字节为"="
        Else
            lngDecodeLen = lngDecodeLen - 1  '最后一个字节为"="
        End If
        bytDecode(lngDecodeLen) = 0  '在实际长度的后一个字节放个结束符
    End If
    'MsgBox "解码后的实际长度为：" & lngDecodeLen
    
    Base64_Decode = bytDecode()
End Function

调用例子(frmMain.frm)： 

Option Explicit
Private Sub cmdDecode_Click()
    Dim bytInText() As Byte
    Dim bytOutText() As Byte
    
    bytInText() = Text1.Text
    bytInText() = StrConv(bytInText(), vbFromUnicode)
    bytOutText() = Base64_Decode(bytInText())
    Open "C:Base64解码后的字符.txt" For Binary As #1
    Put #1, , bytOutText()
    Close #1
    MsgBox "'" & StrConv(bytInText(), vbUnicode) & "'的Base64解码是：" & vbCrLf & vbCrLf & StrConv(bytOutText(), vbUnicode)
    Text2.Text = StrConv(bytOutText(), vbUnicode)
End Sub

Private Sub cmdEncode_Click()
    Dim bytInText() As Byte
    Dim bytOutText() As Byte

    bytInText() = Text1.Text
    bytInText() = StrConv(bytInText(), vbFromUnicode)
    
    bytOutText() = Base64_Encode(bytInText())
    
    Open "C:Base64编码后的字符.txt" For Binary As #1
    Put #1, , bytOutText()
    Close #1
    
    MsgBox "'" & StrConv(bytInText(), vbUnicode) & "'的Base64编码是：" & vbCrLf & vbCrLf & StrConv(bytOutText(), vbUnicode)
    Text2.Text = StrConv(bytOutText(), vbUnicode)
End Sub