</pre><pre name="code" class="vb">'**************************************************************
' 红色金刚石 jinggangshi
'**************************************************************
Option Explicit
'加密算法：
'1 、生成一个加密对照序号表，并存储
'2 、生成基准加密字符表
'3 、根据密码的长度求出向前和向后舍弃的字符长度
'4 、向前和向后舍弃字符，生成加密字符表
'5 、用加密字符表与明文做异或运算，计算出密文
'6 、如何对齐？
'7 、
Public Function EncryptString(ByVal s_mm As String, _
ByVal jmdzxhb As String, _
ByVal i_rnd As Integer, _
ByVal b As Boolean) As String
EncryptString = ""
'密码字符串
If Len(Trim(s_mm)) = 0 Then
Exit Function
End If
Dim a_s_mm() As String
If b Then
a_s_mm = SplitCustom(s_mm)
Else
a_s_mm = Split(s_mm)
End If
'密码长度，作参数用
Dim i_l_mm As Integer
i_l_mm = UBound(a_s_mm) + 1
'1 、生成一个加密对照序号表，并存储
If Trim(jmdzxhb) = "" Then
If b Then
jmdzxhb = Join(CreateRndNumArray(94))
Else
Exit Function '如果是解密必须有原序号表
End If
End If
Dim a_xhb() As String
a_xhb = Split(jmdzxhb, " ")
Dim i_l_xh As Integer
i_l_xh = UBound(a_xhb)
'2 、生成基准加密字符表
Dim jzjmzfb As String
jzjmzfb = Join(CreateChars(0))
'3 、根据密码的长度求出向前和向后舍弃的字符长度
Dim i_left, i_right, i_mid As Integer '前后舍弃字符数，加密取值的步长
Do While i_rnd < 1 Or i_rnd > 9 'Do While的作用是确保CreateRndNum(1, 9)不出错，不生成不符合要求的随机数
If b Then '如果没有加密过，生成一个1-9的随机数，并在加密后存储
i_rnd = CreateRndNum(1, 9)
Else
Exit Function '如果解密，没有随机数无法解密
End If
Loop
i_left = i_rnd + i_l_mm Mod i_rnd
i_right = i_rnd + i_rnd Mod i_l_mm
i_mid = (i_rnd + i_l_mm) Mod (i_l_mm Mod i_rnd + i_rnd Mod i_l_mm) _
+ Int(Abs(i_rnd - i_l_mm) / (i_l_mm Mod i_rnd + i_rnd Mod i_l_mm))
'4 、向前和向后舍弃字符，生成加密字符表
jzjmzfb = Mid(jzjmzfb, i_left * 2 + 1, Len(jzjmzfb) - (i_right + i_left) * 2)
Dim a_s_tmp() As String
a_s_tmp = Split(jzjmzfb, " ")
Dim c_len As Integer '加密字符表的长度
c_len = UBound(a_s_tmp) + 1
'5 、用加密字符表与明文做异或运算，计算出密文
Dim i_step As Integer
i_step = -1 '数组首地址是0，故i_step取－1
Dim mm As String
Dim ret As String
Dim i As Integer
For i = 0 To i_l_mm - 1
i_step = i_step + i_mid '按i_mod设置步长
If i_step >= i_l_xh Then '如果超出加密对照序号表长度，则从头循环
i_step = i_mid - i_step Mod i_l_xh - 1
End If
If b Then
mm = Asc(a_s_mm(i)) Xor Asc(a_s_tmp(CInt(a_xhb(i_step)) Mod c_len)) '对每个字符异或运算
'密钥从舍弃过的基准字符表中取
'位置从对照表中定，如果大于基准字符表则取Mod
mm = Right("0" & Hex$(mm), 2) '转换16进制，按两位格式存储
ret = ret & mm & " " '格式化密码串
Else
mm = Val("&H" & a_s_mm(i)) Xor Asc(a_s_tmp(CInt(a_xhb(i_step)) Mod c_len))
mm = Chr(CInt(mm))
ret = ret & mm '格式化密码串
End If
Next
ret = Trim(ret)
ret = "{" & i_rnd & "," & ret & "," & jmdzxhb & "}"
If ThisWorkbook.IsDevlop Then Debug.Print ret
'6 、如何对齐？
'这个随机数加密完成后存储，并对变量清0
'7 、变量清0
i_rnd = 0
jmdzxhb = ""
EncryptString = ret
End Function
'字符串转换成单个字符数组
Public Function SplitCustom(ByVal s As String) As String()
Dim ret() As String
Dim i As Integer
For i = 0 To Len(s) - 1
ReDim Preserve ret(i)
ret(i) = Mid(s, i + 1, 1)
Next
SplitCustom = ret
End Function
'生成序列数组，即加密解密对照表
Public Function CreateRndNumSTR() As String
CreateRndNumSTR = Join(CreateRndNumArray(94))
End Function
'本函数OK
'生成序列数组，即加密解密对照表
'size生成对照表的大小
'两个值：94 键盘能输入的所有字符
'127 含33个标准字符
Public Function CreateRndNumArray(ByVal size As Integer) As String()
Dim rndNum() As Integer
rndNum = CreateRND(0, size)
Dim rndStr() As String
ReDim rndStr(UBound(rndNum))
Dim str As String
Dim idx As Integer
idx = 0
Dim ch
For Each ch In rndNum
str = CStr(ch)
rndStr(idx) = str
idx = idx + 1
Next
CreateRndNumArray = rndStr
End Function
'本函数OK
'生成字符数组，按顺序
'如果希望包含Chr(32)以下的ASCII码，则inc选true
Public Function CreateChars(ByVal inc As Boolean) As String()
Dim arr() As String
ReDim arr(0)
Dim idx As Integer
idx = 0
Dim i As Integer
For i = 1 To 127
idx = IIf(inc, i, IIf(i - 33 > 0, i - 33, 0))
ReDim Preserve arr(idx) '注意第二个Preserve 保持数据不变
arr(idx) = Chr(i)
Next
CreateChars = arr
End Function
'Dim min As Integer '定义随机数的最小值
'Dim max As Integer '定义随机数的最大值
'限制只产生500个，VBA的速度问题
Public Function CreateRND(ByVal min As Integer, _
ByVal max As Integer) As Integer()
Dim a_size As Integer
a_size = max - min
If a_size > 500 Or max - min + 1 < a_size Then: Exit Function '限制只产生500个，VBA的速度问题
'如果最大值和最小值的差小于数组大小数值就什么也不做
Dim arr() As Integer '定义数组
ReDim arr(a_size) '更改数组大小
Dim flag As Boolean '定义标志变量，用来判断是否有重复值
Randomize (Now()) '用当前时间生成随机数种子
Dim i, j
For i = 0 To a_size '循环生成随机数
Do
arr(i) = Rnd() * (max - min) + min '生成随机数
flag = False
For j = 0 To (i - 1) '循环判断当前的随机数是否和前面生成的随机数相同，如果相同就重新生成
If (arr(i) = arr(j)) Then
flag = True
End If
Next
Loop While flag
'循环中不断生成随机数，直到不重复为止
Next
CreateRND = arr
End Function
Public Function CreateRndNum(ByVal min As Integer, _
ByVal max As Integer) As Integer
If max < min Then: Exit Function
Dim ret As Integer '定义数组
Randomize (Now()) '用当前时间生成随机数种子
ret = Rnd() * (max - min) + min '生成随机数
CreateRndNum = ret
End Function
可逆算法，采用异或方法，密码对照表与随机数两个随机因子，加大了加密的强度。
有兴趣的朋友研究下，提点意见。
转载使用请留下我的名字。