淘先锋技术网

首页 1 2 3 4 5 6 7

VBA写的加密模块 

</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

可逆算法，采用异或方法，密码对照表与随机数两个随机因子，加大了加密的强度。

有兴趣的朋友研究下，提点意见。

转载使用请留下我的名字。