首先这个算法没什么特殊之处，只是怕以后找不到，所以放到了这上面
每个字节加密后有6种结果（占两个字节，如果需要大于6种的话，就要多用1个字节，即占3 个字节），也就是说如果字串占n个字节的话，可能产生的结果为6的n次方个，这个算法破解的强度不大，大家可以完善一下：
'窗体上一个按钮，两个listbox
option explicit
private sub command1_click()
dim i as long
dim s as string
for i = 1 to 100
s = encode("这是一个测试 hello world")
list1.additem s
s = decode(s)
list2.additem s
next
end sub
private function encode(byval s as string) as string '加密
if len(s) = 0 then exit function
dim buff() as byte
buff = strconv(s, vbfromunicode)
dim i as long
dim j as byte
dim k as byte, m as byte
dim mstr as string
mstr = "abcdefghijklmnopqrstuvwxyz0123456789abcdefghijklmnopqrstuvwxyz"
dim outs as string
i = ubound(buff) + 1
outs = space(2 * i)
dim temps as string
for i = 0 to ubound(buff)
randomize time
j = cbyte(5 * (math.rnd()) + 0) '最大产生的随机数只能是5，不能再大了,再大的话，就要多用一个字节
buff(i) = buff(i) xor j
k = buff(i) mod len(mstr)
m = buff(i) \ len(mstr)
m = m * 2 ^ 3 + j
temps = mid(mstr, k + 1, 1) + mid(mstr, m + 1, 1)
mid(outs, 2 * i + 1, 2) = temps
next
encode = outs
end function
private function decode(byval s as string) as string '解密
on error goto myerr
dim i as long
dim j as byte
dim k as byte
dim m as byte
dim mstr as string
mstr = "abcdefghijklmnopqrstuvwxyz0123456789abcdefghijklmnopqrstuvwxyz"
dim t1 as string, t2 as string
dim buff() as byte
dim n as long
n = 0
for i = 1 to len(s) step 2
t1 = mid(s, i, 1)
t2 = mid(s, i + 1, 1)
k = instr(1, mstr, t1) - 1
m = instr(1, mstr, t2) - 1
j = m \ 2 ^ 3
m = m - j * 2 ^ 3
redim preserve buff(n)
buff(n) = j * len(mstr) + k
buff(n) = buff(n) xor m
n = n + 1
next
decode = strconv(buff, vbunicode)
exit function
myerr:
decode = ""
end function
