VB、VBS、VBA 、ASP 的 UTF-8 base64 实现

    先前一直在用的Base64编码（https://blog.csdn.net/jessezappy/article/details/53561739?utm_source=blogxgwz5），一切正常，这几天有个项目需要用 UTF-8 编码 base64 ，随即试了一下，发现结果不同，检查才发现，原 base64 编码使用的是 unicode(GB2312) 数据进行编码的，于是找了个字符串 unicode(GB2312) 转 UTF-8 的函数改造了一下，重新打造了个 VB 的 base84(utf-8)，经测试（https://tool.oschina.net/encrypt?type=3） 工作正确，代码如下：

Public Function UB64EnArr(pasStr, map) '编码MD5的文本型十六进制串数值内容,例：E4B8AD  -----20200524改合
    Dim max, idx, i, L, mAllByteIn()
    L = Len(pasStr) / 2 - 1
    ReDim mAllByteIn(L)
    For i = 0 To L
        mAllByteIn(i) = CByte("&H" & Mid(pasStr, i * 2 + 1, 2))
    Next
    UB64EnArr = UB64En(mAllByteIn, map)
End Function

Public Function UB64En(mAllByteIn, map) '编码去除 unicode 空 0 字符串byte字节数组 -----20200524改合
    Dim max, idx, Base64EncMap(64), BASE_64_MAP_INIT, i, L
    Dim ret, ndx, by3
    Dim first, second, third
    Dim inLangth
    'On Error Resume Next  '---------防止非法字串
    UB64En = ""
    L = UBound(mAllByteIn)
    If (L > 1) Then
        Select Case Len(map) '---20200509改
            Case 0  '标准Base64码表
                BASE_64_MAP_INIT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
            Case 1  '自定义码表1
                BASE_64_MAP_INIT ="略，请自行设置" '---web不能用 = +号,改为用 [ _ 代替'
            Case 2  '标准UUE码表
                BASE_64_MAP_INIT = "`!" & """" & "#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_~"
            Case Else  '直接传入自定义码表
                BASE_64_MAP_INIT = map
        End Select
        max = Len(BASE_64_MAP_INIT)
        For idx = 0 To max - 1
            Base64EncMap(idx) = Asc(Mid(BASE_64_MAP_INIT, idx + 1, 1))
        Next
        inLangth = UBound(mAllByteIn) + 1
        by3 = (inLangth \ 3) * 3
        ndx = 1
        Do While ndx <= by3
            first = mAllByteIn(ndx - 1)
            second = mAllByteIn(ndx + 0)
            third = mAllByteIn(ndx + 1)
            ret = ret & Chr(Base64EncMap((first \ 4) And 63))
            ret = ret & Chr(Base64EncMap(((first * 16) And 48) + ((second \ 16) And 15)))
            ret = ret & Chr(Base64EncMap(((second * 4) And 60) + ((third \ 64) And 3)))
            ret = ret & Chr(Base64EncMap(third And 63))
            ndx = ndx + 3
        Loop
        If by3 < inLangth Then
            first = mAllByteIn(ndx - 1)
            ret = ret & Chr(Base64EncMap((first \ 4) And 63))
            If (inLangth Mod 3) = 2 Then
                second = mAllByteIn(ndx + 0)
                ret = ret & Chr(Base64EncMap(((first * 16) And 48) + ((second \ 16) And 15)))
                ret = ret & Chr(Base64EncMap(((second * 4) And 60))) & Chr(Base64EncMap(UBound(Base64EncMap)))
            Else
                ret = ret & Chr(Base64EncMap((first * 16) And 48))
                ret = ret & Chr(Base64EncMap(UBound(Base64EncMap))) & Chr(Base64EncMap(UBound(Base64EncMap)))
            End If
        End If
        UB64En = ret
    Else
        UB64En = ""
    End If
End Function

Public Function UB64EnStr(pasStr, map, codepage) '编码普通字符串 加入编码类型设置base64_utf8,默认为GB2312 -----20200524改合
    Dim L, mAllByteIn
    'On Error Resume Next  '---------防止非法字串
    UB64EnStr = ""
    L = Len(pasStr) - 1
    If (L > 1) Then
        If UCase(codepage) = "UTF-8" Then
            UB64EnStr = UB64EnArr(str2UTF8(pasStr), map)
        Else
            mAllByteIn = str2arr(pasStr)
            UB64EnStr = UB64En(mAllByteIn, map)
        End If
    Else
        UB64EnStr = ""
    End If
End Function

Public Function str2UTF8(szInput) '只返回十六进制文本串 -----20200524改合
    Dim wch, uch, szRet
    Dim x, i
    Dim nAsc, nAsc2, nAsc3, s2b()
    '如果输入参数为空，则退出函数
    If szInput = "" Then
        str2UTF8 = szInput
        Exit Function
    End If
    '开始转换
    For x = 1 To Len(szInput)
        '利用mid函数分拆GB编码文字
        wch = Mid(szInput, x, 1)
        '利用ascW函数返回每一个GB编码文字的Unicode字符代码
        '注：asc函数返回的是ANSI 字符代码，注意区别
        nAsc = AscW(wch)
        If nAsc < 0 Then
            nAsc = nAsc + 65536
        End If
 
        If (nAsc And &HFF80) = 0 Then
            szRet = szRet & Right("00" & Hex(Asc(wch)), 2)
        Else
            If (nAsc And &HF000) = 0 Then
                uch = Hex(((nAsc \ 64)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            Else
                'GB编码文字的Unicode字符代码在0800 - FFFF之间采用三字节模版 ， 2 ^ 12=4096 ， 2 ^ 6=64
                uch = Hex((nAsc \ 4096) Or &HE0) & _
                      Hex((nAsc \ 64) And &H3F Or &H80) & _
                      Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            End If
        End If
    Next
    '---------翻译为byte数组
'    ReDim s2b(Len(szRet) / 2 - 1)
'    For i = 1 To Len(szRet) Step 2
'        s2b((i - 1) / 2) = CByte("&H" & Mid(szRet, i, 2))
'    Next
    str2UTF8 = szRet
End Function

Public Function str2arr(varstr) '把普通字符串转成二进制数组函数
    Dim i, varlow, varhigh, varasc, varchar, k
    Dim s2b() 'As Byte
    'str2bin = ""
    For i = 0 To Len(varstr) - 1
        varchar = Mid(varstr, i + 1, 1)
        varasc = Asc(varchar)
        ' asc对中文字符求出来的值可能为负数，
        ' 加上65536就可求出它的无符号数值
        ' -1在机器内是用补码表示的0xffff,
        ' 其无符号值为65535,65535=-1+65536
        ' 其他负数依次类推。
        If varasc < 0 Then
            varasc = varasc + 65535
        End If
       '对中文的处理：把双字节低位和高位分开
        If varasc > 255 Then
            varlow = Left(Hex(Asc(varchar)), 2)
            varhigh = Right(Hex(Asc(varchar)), 2)
            'str2bin = str2bin & ChrB("&H" & varlow) & ChrB("&H" & varhigh)
            If i = 0 Then
                ReDim s2b(1)
                k = 0
                s2b(k) = CByte("&H" & varlow) '强制转换为字节，下同
                s2b(k + 1) = CByte("&H" & varhigh)
                k = 1
            Else
                ReDim Preserve s2b(k + 2)
                s2b(k + 1) = CByte("&H" & varlow)
                s2b(k + 2) = CByte("&H" & varhigh)
                k = k + 2
            End If
        Else
            'str2bin = str2bin & ChrB(AscB(varchar))
            If i = 0 Then
                ReDim s2b(0)
                k = 0
                s2b(k) = Asc(varchar)
            Else
                ReDim Preserve s2b(k + 1)
                s2b(k + 1) = Asc(varchar)
                k = k + 1
            End If
        End If
    Next
    str2arr = s2b
End Function

使用范例：

Sub testa()
    Dim a, d
    a = "123中文，？αabc"
    d = UB64EnStr(a, "", "utf-8") '  MTIz5Lit5paH77yM77yfzrFhYmM=
    d = UB64EnStr(a, "", " ")     '  MTIz1tDOxKOso7+mwWFiYw==
End Sub

其实和以前使用的变化仅仅是编码操作使用的字节数组进行了 UTF-8 编码转换而已。

以上代码以去除 AS 标识，可直接用于 VB6、VBS、ASP、VBA

此记！