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
此记！