VBA中调用DES加解密，可以直接用于VBA中（ACCESS，Excel）

最新推荐文章于 2020-12-19 01:58:44 发布

冷冰峰

最新推荐文章于 2020-12-19 01:58:44 发布

阅读量3.1k

点赞数 1

分类专栏： VBA 文章标签： vba 解密 excel access byte integer

本文链接：https://blog.csdn.net/pengkuo/article/details/3748342

版权

VBA 专栏收录该内容

1 篇文章 0 订阅

订阅专栏

'                           ///|///
'                         // - - //
'                          ( @ @ )
'━━━━━━━━━━━━oOOo-(_)-oOOo━━━━━━━━━━━━━━

' Author    : kpeng4
' Email     : pengkuo@sogou.com
' MODULE    : Form_3DES加解密
' Date      : 2009-01-09
' Purpose   : DES/3DES 加解密类模块，及详细的调用
'       1、可直接运行于VBA中，以DES加解密为例，3DES调用基本相同。
'       2、运行前先初始化，一次就行了。
'       3、每次加解密需要调用钥匙设置。
'       4、具体的调用见程序最后。
'       5、明文、密码、密文等均用字节进行的运算。
'       6、密码前8位有效。
'调用规则：
'       1、初始化：Class_Initialize
'       2、3DES的钥匙调用：第一个钥匙：SetKey1
'                          第二个钥匙：SetKey2
'       3、3DES的加解密：Encrypt3Des_ArrToArr(m_bit() As Byte, e_bit() As Byte, Optional bFlag As Byte = 1)
'                        m_bit() As Byte 输入
'                        e_bit() As Byte 输出 ,元素个数为8的倍数
'                        bFlag As Byte 可选输入,为2则解密,其它或为缺省时为加密
'       4、DES的加解密：EncryptDes_ArrToArr(m_bit() As Byte, e_bit() As Byte, Optional bUseKeyNo As Byte = 1, Optional bFlag As Byte = 1)
'                       m_bit() As Byte 输入
'                       e_bit() As Byte 输出 ,元素个数为8的倍数
'                       bUseKeyNo As Byte 可选输入,为2则使用第二个密钥加/解密，否则使用第一个密钥加/解密
'                       bFlag As Byte 可选输入,为2则解密,否则加密
'实例的界面设置：
'       1、3个文本框名字：明文 txtSound，密码 txtPW，密文 txtCryptograph
'       2、2个按钮：加密 cmdEncoder，解密 cmdDecode
'
'                            Oooo
'━━━━━━━━━━oooO━-(   )━━━━━━━━━━━━━━━━━
'                    (   )   ) /
'                     / (   (_/
'                      /_)

'
'======= 私有变量 =======

Private ip(63) As Byte, ip_1(63) As Byte, e(47) As Byte    '数据变换
Private pc_1(55) As Integer, pc_2(47) As Integer, ccmovebit(15) As Integer    '密钥生成
Private p(31) As Byte, ss(7, 3, 15) As Byte    'S变换
Private key_n1(15, 7) As Byte    '密钥1
Private key_n2(15, 7) As Byte    '密钥2

'
'======= API =========
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'
'***************************************************************
'
'==================== 下面是类的函数及方法 ===================
'
'***************************************************************

'==========================================================================================
' SetKey 函数说明：
' 设置3DES加/解密的密钥
' 返回：
' 无
' 参数：
' K_Bit() AS Byte 密钥,不少于16个元素
'==========================================================================================
Sub SetKey(K_Bit() As Byte)
    Dim Key() As Byte
    Dim K_Bit1(7) As Byte
    Dim K_Bit2(7) As Byte

Key = K_Bit
ReDim Preserve Key(15) As Byte

CopyMemory K_Bit1(0), Key(0), 8
CopyMemory K_Bit2(0), Key(8), 8

    '//根据密钥生成16个子密钥
    GenSubKey K_Bit1(), key_n1()
    GenSubKey K_Bit2(), key_n2()
End Sub

'==========================================================================================
' SetKey1 函数说明：
' 设置3DES加/解密的的第一个密钥
' 返回：
' 无
' 参数：
' K_Bit() AS Byte 密钥,不少于8个元素
'==========================================================================================
Sub SetKey1(K_Bit() As Byte)
'//根据密钥生成16个子密钥
    Dim Key() As Byte
    ReDim Preserve Key(7) As Byte
    GenSubKey Key(), key_n1()
End Sub

'=========================================================================================
' SetKey2 函数说明：
' 设置3DES加/解密的的第二个密钥
' 返回：
' 无
' 参数：
' K_Bit() AS Byte 密钥,不少于8个元素
'==========================================================================================
Sub SetKey2(K_Bit() As Byte)
'//根据密钥生成16个子密钥
    Dim Key() As Byte
    ReDim Preserve Key(7) As Byte
    GenSubKey Key(), key_n2()
End Sub

'==========================================================================================
' Encrypt3Des_ArrToArr 函数说明：
' 3DES加/解密
' 返回：
' 无
' 参数：
' m_bit() As Byte 输入
' e_bit() As Byte 输出 ,元素个数为8的倍数
' bFlag As Byte 可选输入,为2则解密,其它或为缺省时为加密
'==========================================================================================
Sub Encrypt3Des_ArrToArr(m_bit() As Byte, e_bit() As Byte, Optional bFlag As Byte = 1)
Dim i As Integer
Dim ina() As Byte, outa() As Byte

    ina = m_bit
    EncryptDes_ArrToArr ina(), outa(), 1, bFlag
    ina = outa
    EncryptDes_ArrToArr ina(), outa(), 2, 3 - bFlag
    ina = outa
    EncryptDes_ArrToArr ina(), outa(), 1, bFlag
    ReDim e_bit(UBound(outa)) As Byte
    'For i = 0 To UBound(outa)
    ' e_bit(i) = outa(i)
    'Next
    CopyMemory e_bit(0), outa(0), UBound(outa) + 1

End Sub

'==========================================================================================
' EncryptDes_ArrToArr 函数说明：
' DES加/解密
' 返回：
' 无
' 参数：
' m_bit() As Byte 输入
' e_bit() As Byte 输出 ,元素个数为8的倍数
' bUseKeyNo As Byte 可选输入,为2则使用第二个密钥加/解密，否则使用第一个密钥加/解密
' bFlag As Byte 可选输入,为2则解密,否则加密
'==========================================================================================
Sub EncryptDes_ArrToArr(m_bit() As Byte, e_bit() As Byte, Optional bUseKeyNo As Byte = 1, Optional bFlag As Byte = 1)
    Dim iSL As Integer
    Dim ina(7) As Byte
    Dim lPos As Long
    Dim outa(7) As Byte
    Dim L As Long, M As Long
    Dim i As Long

If bUseKeyNo <> 2 Then bUseKeyNo = 1

    iSL = UBound(m_bit) + 1
    If iSL Mod 8 <> 0 Then
        iSL = ((iSL / 8) + 1) * 8
    End If

    ReDim e_bit(iSL - 1) As Byte
    L = 0
    Do While L <= UBound(m_bit)
        M = L + 7
        If M > UBound(m_bit) Then M = UBound(m_bit)
        For i = 0 To 7
            ina(i) = 0
        Next
        For i = L To M
            ina(i - L) = m_bit(i)
        Next

endes1 ina(), outa(), bUseKeyNo, bFlag

        For i = 0 To 7
            e_bit(i + L) = outa(i)
        Next
        L = L + 8
    Loop
End Sub

'
'***************************************************************
'
'==================== 下面是私有函数及过程 ===================
'
'***************************************************************

'
'* ArrXor 函数说明：
'* 将输入的两个数组中的字节元素分别作异或运算
'* 返回：
'* 无
'* 参数：'
'* const BYTE in1[] 输入字符串1
'* const BYTE in2[] 输入字符串2
'* BYTE out[] 输出的结果字符串
'*/
Private Sub ArrXor(in1() As Byte, in2() As Byte, outa() As Byte)
    Dim i As Integer
    For i = 0 To UBound(in1)
        outa(i) = in1(i) Xor in2(i)
    Next
End Sub

'/*
' * Bin2ASCII 函数说明：
' * 将64字节的01字符串转换成对应的8个字节
' * 返回：
' * 转换后结果的指针
' * 参数：
' * const BYTE abyte(64) 输入字符串
' * BYTE bit(8) 输出的转换结果
' */
Private Sub Bin2ASCII(abyte() As Byte, bit() As Byte)
    Dim i As Integer
    For i = 0 To 7
        bit(i) = abyte(i * 8) * 128 + abyte(i * 8 + 1) * 64 + _
                 abyte(i * 8 + 2) * 32 + abyte(i * 8 + 3) * 16 + _
                 abyte(i * 8 + 4) * 8 + abyte(i * 8 + 5) * 4 + _
                 abyte(i * 8 + 6) * 2 + abyte(i * 8 + 7)
    Next
End Sub

'/*
' * ASCII2Bin 函数说明：
' * 将8个字节输入转换成对应的64字节的01字符串
' * 返回：
' * 转换后结果的指针
' * 参数：
' * const BYTE bit[8] 输入字符串
' * BYTE byte[64] 输出的转换结果
' */
Private Sub ASCII2Bin(bit() As Byte, abyte() As Byte)
    Dim i As Integer, j As Integer
    For i = 0 To 7
        For j = 0 To 7
            abyte(i * 8 + j) = (bit(i) / (2 ^ (7 - j))) And &H1
        Next
    Next
End Sub

'/*
' * GenSubKey 函数说明：
' * 由输入的密钥得到16个子密钥
' * 返回：
' * 无
' * 参数：
' * const BYTE oldkey[8] 输入密钥
' * BYTE newkey[16][8] 输出的子密钥
' */
Private Sub GenSubKey(oldkey() As Byte, newkey() As Byte)
Dim i As Integer, k As Integer, rol As Integer
Dim s As String

    Dim oldkey_byte(63) As Byte    ' BYTE oldkey_byte[64];
    Dim oldkey_byte1(63) As Byte    ' BYTE oldkey_byte1[64];
    Dim oldkey_byte2(63) As Byte    ' BYTE oldkey_byte2[64];
    Dim oldkey_c(55) As Byte    ' BYTE oldkey_c[56];
    Dim oldkey_d(55) As Byte    ' BYTE oldkey_d[56];
    Dim newkey_byte(15, 63) As Byte    ' BYTE newkey_byte[16][64];
    Dim aT
    Dim abyte(63) As Byte, bbyte(7) As Byte

rol = 0

ASCII2Bin oldkey(), oldkey_byte()

    '//位变换--根据换位表换位压缩成56位密码
    'for(i = 0; i < 56; i++)
    ' oldkey_byte1[i] = oldkey_byte[pc_1[i] - 1];

    For i = 0 To 55
        oldkey_byte1(i) = oldkey_byte(pc_1(i) - 1)
    Next

    '//分为左右两部分，复制一遍以便于循环左移
    'for(i = 0; i < 28; i++)
    ' oldkey_c[i] = oldkey_byte1[i], oldkey_c[i + 28] = oldkey_byte1[i],
    ' oldkey_d[i] = oldkey_byte1[i + 28], oldkey_d[i + 28] = oldkey_byte1[i + 28];

    'For i = 0 To 27
    ' oldkey_c(i) = oldkey_byte1(i)
    ' oldkey_c(i + 28) = oldkey_byte1(i)
    ' oldkey_d(i) = oldkey_byte1(i + 28)
    ' oldkey_d(i + 28) = oldkey_byte1(i + 28)
    'Next
    CopyMemory oldkey_c(0), oldkey_byte1(0), 28
    CopyMemory oldkey_c(28), oldkey_byte1(0), 28
    CopyMemory oldkey_d(0), oldkey_byte1(28), 28
    CopyMemory oldkey_d(28), oldkey_byte1(28), 28

    '//分别生成16个子密钥
    'for(i = 0; i < 16; i++)
    '{
    ' //循环左移
    ' rol += ccmovebit[i];
    ' //合并左移后的结果
    ' for(k = 0; k < 28; k++)
    ' oldkey_byte2[k] = oldkey_c[k + rol], oldkey_byte2[k + 28] = oldkey_d[k + rol];
    ' //位变换
    ' for(k = 0; k < 48; k++)
    ' newkey_byte[i][k] = oldkey_byte2[pc_2[k] - 1];
    '}
    For i = 0 To 15
        '循环左移
        rol = rol + ccmovebit(i)
        '合并左移后的结果
        'For k = 0 To 27
        ' oldkey_byte2(k) = oldkey_c(k + rol)
        ' oldkey_byte2(k + 28) = oldkey_d(k + rol)
        'Next

CopyMemory oldkey_byte2(0), oldkey_c(rol), 28
CopyMemory oldkey_byte2(28), oldkey_d(rol), 28

        '位变换
        For k = 0 To 47
            newkey_byte(i, k) = oldkey_byte2(pc_2(k) - 1)
        Next
    Next

    '生成最终结果
    'for(i = 0; i < 16; i++)
    ' Bin2ASCII(newkey_byte[i], newkey[i]);
    For i = 0 To 15
        For k = 0 To 63
            abyte(k) = newkey_byte(i, k)
        Next

        Bin2ASCII abyte(), bbyte()
        For k = 0 To 7
            newkey(i, k) = bbyte(k)
        Next
    Next
End Sub

'/*
' * endes1 函数说明：
' * DES加密
' * 返回：
' * 无
' * 参数：
' * const BYTE m_bit[8] 输入的原文
' * const BYTE k_bit[8] 输入的密钥
' * BYTE e_bit[8] 输出的密文
' bFlag=1 加 =2解
' */
Private Sub endes1(m_bit() As Byte, e_bit() As Byte, Optional bUseKeyNo As Byte = 1, Optional bFlag As Byte = 1)

Dim s As String

    Dim m_bit1(7) As Byte    ' BYTE m_bit1[8] = {0};
    Dim m_byte(63) As Byte    ' BYTE m_byte[64] = {0};
    Dim m_byte1(63) As Byte    ' BYTE m_byte1[64] = {0};
    'Dim key_n(15, 7) As Byte ' BYTE key_n[16][8] = {0};
    Dim l_bit(16, 7) As Byte    ' BYTE l_bit[17][8] = {0};
    Dim r_bit(16, 7) As Byte    ' BYTE r_bit[17][8] = {0};
    Dim e_byte(63) As Byte    ' BYTE e_byte[64] = {0};
    Dim e_byte1(63) As Byte    ' BYTE e_byte1[64] = {0};
    Dim r_byte(63) As Byte    ' BYTE r_byte[64] = {0};
    Dim r_byte1(63) As Byte    ' BYTE r_byte1[64] = {0};
    Dim key_n

Dim l_bit0(7) As Byte, r_bit0(7) As Byte
Dim l_bit1(7) As Byte, r_bit1(7) As Byte

Dim abyte8(7) As Byte

Dim i As Integer, j As Integer, k As Integer

If bUseKeyNo <> 2 Then bUseKeyNo = 1

If bUseKeyNo = 1 Then key_n = key_n1 Else key_n = key_n2

'//根据密钥生成16个子密钥
'GenSubKey k_bit(), key_n()

'//将待加密字串变换成01串
ASCII2Bin m_bit(), m_byte()

    '//按照ip表对待加密字串进行位变换
    'for(i = 0; i < 64; i++)
    ' m_byte1[i] = m_byte[ip[i] - 1];
    For i = 0 To 63
        m_byte1(i) = m_byte(ip(i) - 1)
    Next

'位变换后的待加密字串
Bin2ASCII m_byte1(), m_bit1()

    '//将位变换后的待加密字串分成两组，分别为前4字节L和后4字节R，作为迭代的基础（第0次迭代）
    'for(i = 0; i < 4; i++)
    ' l_bit[0][i] = m_bit1[i], r_bit[0][i] = m_bit1[i + 4];
    For i = 0 To 3
        'l_bit(0, i) = m_bit1(i)
        'r_bit(0, i) = m_bit1(i + 4)
        CopyMemory l_bit0(0), m_bit1(0), 4
        CopyMemory r_bit0(0), m_bit1(4), 4
    Next

'//16次迭代运算
'for(i = 1; i <= 16; i++)

    For i = 1 To 16
        '//R的上一次的迭代结果作为L的当前次迭代结果
        'for(j = 0; j < 4; j++)
        ' l_bit[i][j] = r_bit[i-1][j];
        'For j = 0 To 3
        ' l_bit(i, j) = r_bit(i - 1, j)
        'Next
        CopyMemory l_bit1(0), r_bit0(0), 4

        'ASCII2Bin(r_bit[i-1], r_byte);
        'For j = 0 To 7
        ' abyte8(j) = r_bit(i - 1, j)
        'Next
        CopyMemory abyte8(0), r_bit0(0), 8

ASCII2Bin abyte8(), r_byte()

        '//将R的上一次迭代结果按E表进行位扩展得到48位中间结果
        'for(j = 0; j < 48; j++)
        ' r_byte1[j] = r_byte[e[j] - 1];
        'Bin2ASCII(r_byte1, r_bit[i-1]);
        For j = 0 To 47
            r_byte1(j) = r_byte(e(j) - 1)
        Next
        Bin2ASCII r_byte1(), abyte8()
        'For j = 0 To 7
        ' r_bit(i - 1, j) = abyte8(j)
        'Next
        CopyMemory r_bit0(0), abyte8(0), 8

        '//与第I-1个子密钥进行异或运算
        'for(j = 0; j < 6; j++)
        ' r_bit[i-1][j] = r_bit[i-1][j] ^ key_n[i-1][j];
        For j = 0 To 5
            If bFlag = 1 Then
                '加
                'r_bit(i - 1, j) = r_bit(i - 1, j) Xor key_n(i - 1, j)
                r_bit0(j) = r_bit0(j) Xor key_n(i - 1, j)
            Else
                '解
                'r_bit(i - 1, j) = r_bit(i - 1, j) Xor key_n((17 - i) - 1, j)
                r_bit0(j) = r_bit0(j) Xor key_n((17 - i) - 1, j)
            End If
        Next

        '//进行S选择，得到32位中间结果
        'SReplace(r_bit[i - 1]);
        'For j = 0 To 7
        ' abyte8(j) = r_bit(i - 1, j)
        'Next
        CopyMemory abyte8(0), r_bit0(0), 8

        SReplace abyte8()
        'For j = 0 To 7
        ' r_bit(i - 1, j) = abyte8(j)
        'Next
        CopyMemory r_bit0(0), abyte8(0), 8

        '//结果与L的上次迭代结果异或得到R的此次迭代结果
        'for(j = 0; j < 4; j++)
        '{
        ' r_bit[i][j] = l_bit[i-1][j] ^ r_bit[i-1][j];
        '}
        For j = 0 To 3
            'r_bit(i, j) = l_bit(i - 1, j) Xor r_bit(i - 1, j)
            r_bit1(j) = l_bit0(j) Xor r_bit0(j)
        Next

        CopyMemory l_bit0(0), l_bit1(0), 8
        CopyMemory r_bit0(0), r_bit1(0), 8
    Next

    '//组合最终迭代结果
    'for(i = 0; i < 4; i++)
    ' e_bit[i] = r_bit[16][i], e_bit[i + 4] = l_bit[16][i];
    'For i = 0 To 3
    ' e_bit(i) = r_bit(16, i)
    ' e_bit(i + 4) = l_bit(16, i)
    'Next
    CopyMemory e_bit(0), r_bit1(0), 4
    CopyMemory e_bit(4), l_bit1(0), 4

ASCII2Bin e_bit(), e_byte()

    '//按照表IP-1进行位变换
    'for(i = 0; i < 64; i++)
    ' e_byte1[i] = e_byte[ip_1[i] - 1];
    For i = 0 To 63
        e_byte1(i) = e_byte(ip_1(i) - 1)
    Next

'//得到最后的加密结果
Bin2ASCII e_byte1(), e_bit()
End Sub

'/*
' * SReplace 函数说明：
' * S选择
' * 返回：
' * 无
' * 参数：
' * BYTE s_bit[8] 输入暨选择后的输出
' */
Private Sub SReplace(s_bit() As Byte)

Dim i As Integer

    Dim s_byte(63) As Byte    ' BYTE s_byte[64] = {0};
    Dim s_byte1(63) As Byte    ' BYTE s_byte1[64] = {0};
    Dim row As Byte, col As Byte
    Dim s_out_bit(7) As Byte    'BYTE s_out_bit[8] = {0};

row = 0: col = 0

    '//转成二进制字符串处理
    ASCII2Bin s_bit(), s_byte()
    'for(int i = 0; i < 8; i++)
    '{
    ' //0、5位为row，1、2、3、4位为col，在S表中选择一个八位的数
    ' row = s_byte[i * 6] * 2 + s_byte[i * 6 + 5];
    ' col = s_byte[i * 6 + 1] * 8 + s_byte[i * 6 + 2] * 4 + s_byte[i * 6 + 3] * 2 + s_byte[i * 6 + 4];
    ' s_out_bit[i] = s[i][row][col];
    '}
    For i = 0 To 7
        '0、5位为row，1、2、3、4位为col，在S表中选择一个八位的数
        row = s_byte(i * 6) * 2 + s_byte(i * 6 + 5)
        col = s_byte(i * 6 + 1) * 8 + s_byte(i * 6 + 2) * 4 + s_byte(i * 6 + 3) * 2 + s_byte(i * 6 + 4)
        s_out_bit(i) = ss(i, row, col)
    Next

    '//将八个选择的八位数据压缩表示
    's_out_bit[0] = (s_out_bit[0] << 4) + s_out_bit[1];
    's_out_bit[1] = (s_out_bit[2] << 4) + s_out_bit[3];
    's_out_bit[2] = (s_out_bit[4] << 4) + s_out_bit[5];
    's_out_bit[3] = (s_out_bit[6] << 4) + s_out_bit[7];
    s_out_bit(0) = s_out_bit(0) * (2 ^ 4) + s_out_bit(1)
    s_out_bit(1) = s_out_bit(2) * (2 ^ 4) + s_out_bit(3)
    s_out_bit(2) = s_out_bit(4) * (2 ^ 4) + s_out_bit(5)
    s_out_bit(3) = s_out_bit(6) * (2 ^ 4) + s_out_bit(7)

'//转成二进制字符串处理
ASCII2Bin s_out_bit(), s_byte()

    '//换位
    'for(i = 0; i < 32; i++)
    ' s_byte1[i] = s_byte[p[i] - 1];
    For i = 0 To 31
        s_byte1(i) = s_byte(p(i) - 1)
    Next

'//生成最后结果
Bin2ASCII s_byte1(), s_bit()

End Sub

Private Sub Class_Initialize()
    Dim i As Integer, j As Integer, k As Integer, L As Integer
    Dim aT, s As String
    '//换位表IP
    s = "58,50,42,34,26,18,10,2," & _
        "60,52,44,36,28,20,12,4," & _
        "62,54,46,38,30,22,14,6," & _
        "64,56,48,40,32,24,16,8," & _
        "57,49,41,33,25,17,9,1," & _
        "59,51,43,35,27,19,11,3," & _
        "61,53,45,37,29,21,13,5," & _
        "63,55,47,39,31,23,15,7"
    aT = Split(s, ",")
    For i = 0 To 63: ip(i) = val(aT(i)): Next

    '//换位表IP_1
    s = "40,8,48,16,56,24,64,32," & _
        "39,7,47,15,55,23,63,31," & _
        "38,6,46,14,54,22,62,30," & _
        "37,5,45,13,53,21,61,29," & _
        "36,4,44,12,52,20,60,28," & _
        "35,3,43,11,51,19,59,27," & _
        "34,2,42,10,50,18,58,26," & _
        "33,1,41,9,49,17,57,25"
    aT = Split(s, ",")
    For i = 0 To 63: ip_1(i) = val(aT(i)): Next

    '//放大换位表
    s = "32,1, 2, 3, 4, 5," & _
        "4, 5, 6, 7, 8, 9," & _
        "8, 9, 10,11,12,13," & _
        "12,13,14,15,16,17," & _
        "16,17,18,19,20,21," & _
        "20,21,22,23,24,25," & _
        "24,25,26,27,28,29," & _
        "28,29,30,31,32,1"
    aT = Split(s, ",")
    For i = 0 To 47: e(i) = val(aT(i)): Next

    '缩小换位表1
    s = "57,49,41,33,25,17,9," & _
        "1,58,50,42,34,26,18," & _
        "10,2,59,51,43,35,27," & _
        "19,11,3,60,52,44,36," & _
        "63,55,47,39,31,23,15," & _
        "7,62,54,46,38,30,22," & _
        "14,6,61,53,45,37,29," & _
        "21,13,5,28,20,12,4"
    aT = Split(s, ",")
    For i = 0 To 55: pc_1(i) = val(aT(i)): Next

    '//缩小换位表2
    s = "14,17,11,24,1,5," & _
        "3,28,15,6,21,10," & _
        "23,19,12,4,26,8," & _
        "16,7,27,20,13,2," & _
        "41,52,31,37,47,55," & _
        "30,40,51,45,33,48," & _
        "44,49,39,56,34,53," & _
        "46,42,50,36,29,32"
    aT = Split(s, ",")
    For i = 0 To 47: pc_2(i) = val(aT(i)): Next

    '//16次循环左移对应的左移位数
    s = "1,1,2,2,2,2,2,2,1,2,2,2,2,2,2,1"
    aT = Split(s, ",")
    For i = 0 To 15: ccmovebit(i) = val(aT(i)): Next

    s = "16,7,20,21," & _
        "29,12,28,17," & _
        "1,15,23,26," & _
        "5,18,31,10," & _
        "2,8,24,14," & _
        "32,27,3,9," & _
        "19,13,30,6," & _
        "22,11,4,25"
    aT = Split(s, ",")
    For i = 0 To 31
        p(i) = val(aT(i))
    Next

    s = "14,4,13,1,2,15,11,8,3,10,6,12,5,9,0,7," & _
        "0,15,7,4,14,2,13,1,10,6,12,11,9,5,3,8," & _
        "4,1,14,8,13,6,2,11,15,12,9,7,3,10,5,0," & _
        "15,12,8,2,4,9,1,7,5,11,3,14,10,0,6,13," & _
        "15,1,8,14,6,11,3,4,9,7,2,13,12,0,5,10," & _
        "3,13,4,7,15,2,8,14,12,0,1,10,6,9,11,5," & _
        "0,14,7,11,10,4,13,1,5,8,12,6,9,3,2,15," & _
        "13,8,10,1,3,15,4,2,11,6,7,12,0,5,14,9," & _
        "10,0,9,14,6,3,15,5,1,13,12,7,11,4,2,8," & _
        "13,7,0,9,3,4,6,10,2,8,5,14,12,11,15,1," & _
        "13,6,4,9,8,15,3,0,11,1,2,12,5,10,14,7," & _
        "1,10,13,0,6,9,8,7,4,15,14,3,11,5,2,12," & _
        "7,13,14,3,0,6,9,10,1,2,8,5,11,12,4,15," & _
        "13,8,11,5,6,15,0,3,4,7,2,12,1,10,14,9," & _
        "10,6,9,0,12,11,7,13,15,1,3,14,5,2,8,4," & _
        "3,15,0,6,10,1,13,8,9,4,5,11,12,7,2,14,"

    s = s & _
        "2,12,4,1,7,10,11,6,8,5,3,15,13,0,14,9," & _
        "14,11,2,12,4,7,13,1,5,0,15,10,3,9,8,6," & _
        "4,2,1,11,10,13,7,8,15,9,12,5,6,3,0,14," & _
        "11,8,12,7,1,14,2,13,6,15,0,9,10,4,5,3," & _
        "12,1,10,15,9,2,6,8,0,13,3,4,14,7,5,11," & _
        "10,15,4,2,7,12,9,5,6,1,13,14,0,11,3,8," & _
        "9,14,15,5,2,8,12,3,7,0,4,10,1,13,11,6," & _
        "4,3,2,12,9,5,15,10,11,14,1,7,6,0,8,13," & _
        "4,11,2,14,15,0,8,13,3,12,9,7,5,10,6,1," & _
        "13,0,11,7,4,9,1,10,14,3,5,12,2,15,8,6," & _
        "1,4,11,13,12,3,7,14,10,15,6,8,0,5,9,2," & _
        "6,11,13,8,1,4,10,7,9,5,0,15,14,2,3,12," & _
        "13,2,8,4,6,15,11,1,10,9,3,14,5,0,12,7," & _
        "1,15,13,8,10,3,7,4,12,5,6,11,0,14,9,2," & _
        "7,11,4,1,9,12,14,2,0,6,10,13,15,3,5,8," & _
        "2,1,14,7,4,10,8,13,15,12,9,0,3,5,6,11"
    aT = Split(s, ",")
    L = 0
    For i = 0 To 7
        For j = 0 To 3
            For k = 0 To 15
                ss(i, j, k) = val(aT(L))
                L = L + 1
            Next
        Next
    Next

End Sub

'                              (0 0)
' +---------------------oOO----(_)--------------------------+
'
'   Author    : kpeng4
'   Email     : pengkuo@sogou.com
'   Procedure : cmdDecode_Click
'   Date      : 2009-01-09
'   Purpose   : 解密程序的调用
'
' +------------------------------------oOO------------------+
'                            |__|__|
'                             || ||
'                            ooO Ooo
Private Sub cmdDecode_Click()
    Dim bytOutput() As Byte
    Dim bytInput() As Byte
    Dim bytKey() As Byte
    Dim bytTmp(0 To 1) As Byte
    Dim i As Integer
    ReDim bytInput(0 To Len(Me.txtCryptograph) / 2)
    For i = 0 To Len(Me.txtCryptograph) - 1 Step 2
        bytInput(i / 2) = CByte("&H" & Mid(Me.txtCryptograph, i + 1, 2))
    Next i
    bytKey = StrConv(Me.txtPW, vbFromUnicode)
    Call SetKey(bytKey)
    Call EncryptDes_ArrToArr(bytInput, bytOutput, 1, 2)
    Me.txtSound = ""
    For i = 0 To UBound(bytOutput) - 1
        If bytOutput(i) = 0 Then Exit For
        If bytOutput(i) > 31 And bytOutput(i) < 129 Then
            Me.txtSound = Me.txtSound & Chr(bytOutput(i))
        Else
            bytTmp(0) = bytOutput(i)
            bytTmp(1) = bytOutput(i + 1)
            i = i + 1
            Me.txtSound = Me.txtSound & StrConv(bytTmp, vbUnicode)
        End If
    Next i
End Sub

'                              (0 0)
' +---------------------oOO----(_)--------------------------+
'
'   Author    : kpeng4
'   Email     : pengkuo@sogou.com
'   Procedure : cmdEncoder_Click
'   Date      : 2009-01-09
'   Purpose   : 加密程序的调用
'
' +------------------------------------oOO------------------+
'                            |__|__|
'                             || ||
'                            ooO Ooo
Private Sub cmdEncoder_Click()
    Dim bytOutput() As Byte
    Dim bytInput() As Byte
    Dim bytKey() As Byte
    Dim i As Integer
    bytInput = StrConv(Me.txtSound, vbFromUnicode)
    bytKey = StrConv(Me.txtPW, vbFromUnicode)
    Call SetKey(bytKey)
    Call EncryptDes_ArrToArr(bytInput, bytOutput, 1, 1)
    Me.txtCryptograph = ""
    For i = 0 To UBound(bytOutput)
        If bytOutput(i) < 16 Then    '如果不进行判断在，密文：wwsw的w 密码：是33333 的时候将无法还原
            Me.txtCryptograph = Me.txtCryptograph & "0" & Hex(bytOutput(i))
        Else
            Me.txtCryptograph = Me.txtCryptograph & Hex(bytOutput(i))
        End If
    Next i
End Sub

'                              (0 0)
' +---------------------oOO----(_)--------------------------+
'
'   Author    : kpeng4
'   Email     : pengkuo@sogou.com
'   Procedure : Form_Load
'   Date      : 2009-01-09
'   Purpose   : 数据的初始化
'
' +------------------------------------oOO------------------+
'                            |__|__|
'                             || ||
'                            ooO Ooo
Private Sub Form_Load()
    Call Class_Initialize
End Sub

冷冰峰

关注

1
点赞
踩
3

收藏

觉得还不错? 一键收藏
1
评论
VBA中调用DES加解密，可以直接用于VBA中（ACCESS，Excel）

///|/// // - - // ( @ @ )━━━━━━━━━━━━oOOo-(_)-oOOo━━━━━━━━━━━━━━ Author : kpeng4 Email : pengkuo@sogou.co
复制链接

扫一扫