一个 VBS 写的 Base64 + UUE 编码程序源码，可自定义编码表

jessezappy

已于 2023-04-18 15:32:03 修改

阅读量1.2w

点赞数 1

分类专栏：编程基础日记研究心得文章标签： vb Base64 UUE 加密解密自定义编码表

于 2009-07-08 23:15:00 首次发布

本文链接：https://blog.csdn.net/jessezappy/article/details/4332724

版权

研究心得同时被 3 个专栏收录

34 篇文章 1 订阅

订阅专栏

日记

32 篇文章 2 订阅

订阅专栏

编程基础

20 篇文章 1 订阅

订阅专栏

以下内容仅作为 http://topic.csdn.net/u/20090707/00/0b3b4c31-8cef-4bd2-817e-4a2a445e8b87.html?seed=1787678774 之素材，不代表其他含义。

应网友要求，现提供VB6源码下载（仅核心编码解码模块，不含界面，界面请自行设计）：http://download.csdn.net/download/jessezappy/10028248

改进版纯字符串编码解码的易移植源码下载：http://download.csdn.net/download/jessezappy/9707790

今天做了个Base64编码程序，本想将二进制文件编码后可以直接在论坛或Blog上发布，而不用再担心不能上传附件的问题，当然了，只是针对小文件而言，超过几M的大文件不在此列。

20210422 PS：好吧，这篇2009年的老文章居然被判定为“非专业IT知识”文章，那么我就把之前文本内容的那个RAR解压就可以用的程序删了，改为放上近几年新做的：简易可自定义编码表及 Base64+UUE 编码的核心代码发出来。这个代码不包含 UUE 折行切分的部分，如果需要生成 UUE 文件，则需要自己写段 UUE 折行及加行标识的代码即可。

目前我使用该代码最多的用途是使用自定义编码表加密信息，传输后解密。我个人觉得自定义编码表加密的信息以目前的技术应该是无法被破解的，

如有破解高手请留言PK。

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 Uri 不能用 = / + 号,改为用 -_. 代替'
            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