1 Option Explicit 2 '添加类模块并复制该内容即可 3 '======DES加密====== 4 '加密模式：ECB 5 '填充：zeropadding 6 '输出字符集：base64 7 8 '======用法====== 9 '加密 10 ' DES.Key = "" 11 ' DES.EncryptString(date, Key) 12 '解密 13 'DES.DecryptString(date, Key) 14 15 '====== 16 17 'For progress notifications 18 Event Progress(Percent As Long) 19 20 'Key-dependant 21 Private m_Key(0 To 47, 1 To 16) As Byte 22 23 'Buffered key value 24 Private m_KeyValue As String 25 26 'Values given in the DES standard 27 Private m_E(0 To 63) As Byte 28 Private m_P(0 To 31) As Byte 29 Private m_IP(0 To 63) As Byte 30 Private m_PC1(0 To 55) As Byte 31 Private m_PC2(0 To 47) As Byte 32 Private m_IPInv(0 To 63) As Byte 33 Private m_EmptyArray(0 To 63) As Byte 34 Private m_LeftShifts(1 To 16) As Byte 35 Private m_sBox(0 To 7, 0 To 1, 0 To 1, 0 To 1, 0 To 1, 0 To 1, 0 To 1) As Long 36 37 Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 38 39 Private Static Sub Byte2Bin(ByteArray() As Byte, ByteLen As Long, BinaryArray() As Byte) 40 Dim A As Long 41 Dim ByteValue As Byte 42 Dim BinLength As Long 43 44 'Clear the destination array, faster than 45 'setting the data to zero in the loop below 46 Call CopyMem(BinaryArray(0), m_EmptyArray(0), ByteLen * 8) 47 48 'Add binary 1's where needed 49 BinLength = 0 50 For A = 0 To (ByteLen - 1) 51 ByteValue = ByteArray(A) 52 If (ByteValue And 128) Then BinaryArray(BinLength) = 1 53 If (ByteValue And 64) Then BinaryArray(BinLength + 1) = 1 54 If (ByteValue And 32) Then BinaryArray(BinLength + 2) = 1 55 If (ByteValue And 16) Then BinaryArray(BinLength + 3) = 1 56 If (ByteValue And 8) Then BinaryArray(BinLength + 4) = 1 57 If (ByteValue And 4) Then BinaryArray(BinLength + 5) = 1 58 If (ByteValue And 2) Then BinaryArray(BinLength + 6) = 1 59 If (ByteValue And 1) Then BinaryArray(BinLength + 7) = 1 60 BinLength = BinLength + 8 61 Next 62 63 End Sub 64 Private Static Sub Bin2Byte(BinaryArray() As Byte, ByteLen As Long, ByteArray() As Byte) 65 66 Dim A As Long 67 Dim ByteValue As Byte 68 Dim BinLength As Long 69 70 'Calculate byte values 71 BinLength = 0 72 For A = 0 To (ByteLen - 1) 73 ByteValue = 0 74 If (BinaryArray(BinLength) = 1) Then ByteValue = ByteValue + 128 75 If (BinaryArray(BinLength + 1) = 1) Then ByteValue = ByteValue + 64 76 If (BinaryArray(BinLength + 2) = 1) Then ByteValue = ByteValue + 32 77 If (BinaryArray(BinLength + 3) = 1) Then ByteValue = ByteValue + 16 78 If (BinaryArray(BinLength + 4) = 1) Then ByteValue = ByteValue + 8 79 If (BinaryArray(BinLength + 5) = 1) Then ByteValue = ByteValue + 4 80 If (BinaryArray(BinLength + 6) = 1) Then ByteValue = ByteValue + 2 81 If (BinaryArray(BinLength + 7) = 1) Then ByteValue = ByteValue + 1 82 ByteArray(A) = ByteValue 83 BinLength = BinLength + 8 84 Next 85 86 End Sub 87 Private Static Sub EncryptBlock(BlockData() As Byte) 88 89 Dim A As Long 90 Dim i As Long 91 Dim L(0 To 31) As Byte 92 Dim R(0 To 31) As Byte 93 Dim RL(0 To 63) As Byte 94 Dim sBox(0 To 31) As Byte 95 Dim LiRi(0 To 31) As Byte 96 Dim ERxorK(0 To 47) As Byte 97 Dim BinBlock(0 To 63) As Byte 98 99 'Convert the block into a binary array 100 '(I do believe this is the best solution 101 'in VB for the DES algorithm, but it is 102 'still slow as xxxx) 103 Call Byte2Bin(BlockData(), 8, BinBlock()) 104 105 'Apply the IP permutation and split the 106 'block into two halves, L[] and R[] 107 For A = 0 To 31 108 L(A) = BinBlock(m_IP(A)) 109 R(A) = BinBlock(m_IP(A + 32)) 110 Next 111 112 'Apply the 16 subkeys on the block 113 For i = 1 To 16 114 'E(R[i]) xor K[i] 115 ERxorK(0) = R(31) Xor m_Key(0, i) 116 ERxorK(1) = R(0) Xor m_Key(1, i) 117 ERxorK(2) = R(1) Xor m_Key(2, i) 118 ERxorK(3) = R(2) Xor m_Key(3, i) 119 ERxorK(4) = R(3) Xor m_Key(4, i) 120 ERxorK(5) = R(4) Xor m_Key(5, i) 121 ERxorK(6) = R(3) Xor m_Key(6, i) 122 ERxorK(7) = R(4) Xor m_Key(7, i) 123 ERxorK(8) = R(5) Xor m_Key(8, i) 124 ERxorK(9) = R(6) Xor m_Key(9, i) 125 ERxorK(10) = R(7) Xor m_Key(10, i) 126 ERxorK(11) = R(8) Xor m_Key(11, i) 127 ERxorK(12) = R(7) Xor m_Key(12, i) 128 ERxorK(13) = R(8) Xor m_Key(13, i) 129 ERxorK(14) = R(9) Xor m_Key(14, i) 130 ERxorK(15) = R(10) Xor m_Key(15, i) 131 ERxorK(16) = R(11) Xor m_Key(16, i) 132 ERxorK(17) = R(12) Xor m_Key(17, i) 133 ERxorK(18) = R(11) Xor m_Key(18, i) 134 ERxorK(19) = R(12) Xor m_Key(19, i) 135 ERxorK(20) = R(13) Xor m_Key(20, i) 136 ERxorK(21) = R(14) Xor m_Key(21, i) 137 ERxorK(22) = R(15) Xor m_Key(22, i) 138 ERxorK(23) = R(16) Xor m_Key(23, i) 139 ERxorK(24) = R(15) Xor m_Key(24, i) 140 ERxorK(25) = R(16) Xor m_Key(25, i) 141 ERxorK(26) = R(17) Xor m_Key(26, i) 142 ERxorK(27) = R(18) Xor m_Key(27, i) 143 ERxorK(28) = R(19) Xor m_Key(28, i) 144 ERxorK(29) = R(20) Xor m_Key(29, i) 145 ERxorK(30) = R(19) Xor m_Key(30, i) 146 ERxorK(31) = R(20) Xor m_Key(31, i) 147 ERxorK(32) = R(21) Xor m_Key(32, i) 148 ERxorK(33) = R(22) Xor m_Key(33, i) 149 ERxorK(34) = R(23) Xor m_Key(34, i) 150 ERxorK(35) = R(24) Xor m_Key(35, i) 151 ERxorK(36) = R(23) Xor m_Key(36, i) 152 ERxorK(37) = R(24) Xor m_Key(37, i) 153 ERxorK(38) = R(25) Xor m_Key(38, i) 154 ERxorK(39) = R(26) Xor m_Key(39, i) 155 ERxorK(40) = R(27) Xor m_Key(40, i) 156 ERxorK(41) = R(28) Xor m_Key(41, i) 157 ERxorK(42) = R(27) Xor m_Key(42, i) 158 ERxorK(43) = R(28) Xor m_Key(43, i) 159 ERxorK(44) = R(29) Xor m_Key(44, i) 160 ERxorK(45) = R(30) Xor m_Key(45, i) 161 ERxorK(46) = R(31) Xor m_Key(46, i) 162 ERxorK(47) = R(0) Xor m_Key(47, i) 163 164 'Apply the s-boxes 165 Call CopyMem(sBox(0), m_sBox(0, ERxorK(0), ERxorK(1), ERxorK(2), ERxorK(3), ERxorK(4), ERxorK(5)), 4) 166 Call CopyMem(sBox(4), m_sBox(1, ERxorK(6), ERxorK(7), ERxorK(8), ERxorK(9), ERxorK(10), ERxorK(11)), 4) 167 Call CopyMem(sBox(8), m_sBox(2, ERxorK(12), ERxorK(13), ERxorK(14), ERxorK(15), ERxorK(16), ERxorK(17)), 4) 168 Call CopyMem(sBox(12), m_sBox(3, ERxorK(18), ERxorK(19), ERxorK(20), ERxorK(21), ERxorK(22), ERxorK(23)), 4) 169 Call CopyMem(sBox(16), m_sBox(4, ERxorK(24), ERxorK(25), ERxorK(26), ERxorK(27), ERxorK(28), ERxorK(29)), 4) 170 Call CopyMem(sBox(20), m_sBox(5, ERxorK(30), ERxorK(31), ERxorK(32), ERxorK(33), ERxorK(34), ERxorK(35)), 4) 171 Call CopyMem(sBox(24), m_sBox(6, ERxorK(36), ERxorK(37), ERxorK(38), ERxorK(39), ERxorK(40), ERxorK(41)), 4) 172 Call CopyMem(sBox(28), m_sBox(7, ERxorK(42), ERxorK(43), ERxorK(44), ERxorK(45), ERxorK(46), ERxorK(47)), 4) 173 174 'L[i] xor P(R[i]) 175 LiRi(0) = L(0) Xor sBox(15) 176 LiRi(1) = L(1) Xor sBox(6) 177 LiRi(2) = L(2) Xor sBox(19) 178 LiRi(3) = L(3) Xor sBox(20) 179 LiRi(4) = L(4) Xor sBox(28) 180 LiRi(5) = L(5) Xor sBox(11) 181 LiRi(6) = L(6) Xor sBox(27) 182 LiRi(7) = L(7) Xor sBox(16) 183 LiRi(8) = L(8) Xor sBox(0) 184 LiRi(9) = L(9) Xor sBox(14) 185 LiRi(10) = L(10) Xor sBox(22) 186 LiRi(11) = L(11) Xor sBox(25) 187 LiRi(12) = L(12) Xor sBox(4) 188 LiRi(13) = L(13) Xor sBox(17) 189 LiRi(14) = L(14) Xor sBox(30) 190 LiRi(15) = L(15) Xor sBox(9) 191 LiRi(16) = L(16) Xor sBox(1) 192 LiRi(17) = L(17) Xor sBox(7) 193 LiRi(18) = L(18) Xor sBox(23) 194 LiRi(19) = L(19) Xor sBox(13) 195 LiRi(20) = L(20) Xor sBox(31) 196 LiRi(21) = L(21) Xor sBox(26) 197 LiRi(22) = L(22) Xor sBox(2) 198 LiRi(23) = L(23) Xor sBox(8) 199 LiRi(24) = L(24) Xor sBox(18) 200 LiRi(25) = L(25) Xor sBox(12) 201 LiRi(26) = L(26) Xor sBox(29) 202 LiRi(27) = L(27) Xor sBox(5) 203 LiRi(28) = L(28) Xor sBox(21) 204 LiRi(29) = L(29) Xor sBox(10) 205 LiRi(30) = L(30) Xor sBox(3) 206 LiRi(31) = L(31) Xor sBox(24) 207 208 'Prepare for next round 209 Call CopyMem(L(0), R(0), 32) 210 Call CopyMem(R(0), LiRi(0), 32) 211 Next 212 213 'Concatenate R[]L[] 214 Call CopyMem(RL(0), R(0), 32) 215 Call CopyMem(RL(32), L(0), 32) 216 217 'Apply the invIP permutation 218 For A = 0 To 63 219 BinBlock(A) = RL(m_IPInv(A)) 220 Next 221 222 'Convert the binaries into a byte array 223 Call Bin2Byte(BinBlock(), 8, BlockData()) 224 225 End Sub 226 Private Static Sub DecryptBlock(BlockData() As Byte) 227 228 Dim A As Long 229 Dim i As Long 230 Dim L(0 To 31) As Byte 231 Dim R(0 To 31) As Byte 232 Dim RL(0 To 63) As Byte 233 Dim sBox(0 To 31) As Byte 234 Dim LiRi(0 To 31) As Byte 235 Dim ERxorK(0 To 47) As Byte 236 Dim BinBlock(0 To 63) As Byte 237 238 'Convert the block into a binary array 239 '(I do believe this is the best solution 240 'in VB for the DES algorithm, but it is 241 'still slow as xxxx) 242 Call Byte2Bin(BlockData(), 8, BinBlock()) 243 244 'Apply the IP permutation and split the 245 'block into two halves, L[] and R[] 246 For A = 0 To 31 247 L(A) = BinBlock(m_IP(A)) 248 R(A) = BinBlock(m_IP(A + 32)) 249 Next 250 251 'Apply the 16 subkeys on the block 252 For i = 16 To 1 Step -1 253 'E(R[i]) xor K[i] 254 ERxorK(0) = R(31) Xor m_Key(0, i) 255 ERxorK(1) = R(0) Xor m_Key(1, i) 256 ERxorK(2) = R(1) Xor m_Key(2, i) 257 ERxorK(3) = R(2) Xor m_Key(3, i) 258 ERxorK(4) = R(3) Xor m_Key(4, i) 259 ERxorK(5) = R(4) Xor m_Key(5, i) 260 ERxorK(6) = R(3) Xor m_Key(6, i) 261 ERxorK(7) = R(4) Xor m_Key(7, i) 262 ERxorK(8) = R(5) Xor m_Key(8, i) 263 ERxorK(9) = R(6) Xor m_Key(9, i) 264 ERxorK(10) = R(7) Xor m_Key(10, i) 265 ERxorK(11) = R(8) Xor m_Key(11, i) 266 ERxorK(12) = R(7) Xor m_Key(12, i) 267 ERxorK(13) = R(8) Xor m_Key(13, i) 268 ERxorK(14) = R(9) Xor m_Key(14, i) 269 ERxorK(15) = R(10) Xor m_Key(15, i) 270 ERxorK(16) = R(11) Xor m_Key(16, i) 271 ERxorK(17) = R(12) Xor m_Key(17, i) 272 ERxorK(18) = R(11) Xor m_Key(18, i) 273 ERxorK(19) = R(12) Xor m_Key(19, i) 274 ERxorK(20) = R(13) Xor m_Key(20, i) 275 ERxorK(21) = R(14) Xor m_Key(21, i) 276 ERxorK(22) = R(15) Xor m_Key(22, i) 277 ERxorK(23) = R(16) Xor m_Key(23, i) 278 ERxorK(24) = R(15) Xor m_Key(24, i) 279 ERxorK(25) = R(16) Xor m_Key(25, i) 280 ERxorK(26) = R(17) Xor m_Key(26, i) 281 ERxorK(27) = R(18) Xor m_Key(27, i) 282 ERxorK(28) = R(19) Xor m_Key(28, i) 283 ERxorK(29) = R(20) Xor m_Key(29, i) 284 ERxorK(30) = R(19) Xor m_Key(30, i) 285 ERxorK(31) = R(20) Xor m_Key(31, i) 286 ERxorK(32) = R(21) Xor m_Key(32, i) 287 ERxorK(33) = R(22) Xor m_Key(33, i) 288 ERxorK(34) = R(23) Xor m_Key(34, i) 289 ERxorK(35) = R(24) Xor m_Key(35, i) 290 ERxorK(36) = R(23) Xor m_Key(36, i) 291 ERxorK(37) = R(24) Xor m_Key(37, i) 292 ERxorK(38) = R(25) Xor m_Key(38, i) 293 ERxorK(39) = R(26) Xor m_Key(39, i) 294 ERxorK(40) = R(27) Xor m_Key(40, i) 295 ERxorK(41) = R(28) Xor m_Key(41, i) 296 ERxorK(42) = R(27) Xor m_Key(42, i) 297 ERxorK(43) = R(28) Xor m_Key(43, i) 298 ERxorK(44) = R(29) Xor m_Key(44, i) 299 ERxorK(45) = R(30) Xor m_Key(45, i) 300 ERxorK(46) = R(31) Xor m_Key(46, i) 301 ERxorK(47) = R(0) Xor m_Key(47, i) 302 303 'Apply the s-boxes 304 Call CopyMem(sBox(0), m_sBox(0, ERxorK(0), ERxorK(1), ERxorK(2), ERxorK(3), ERxorK(4), ERxorK(5)), 4) 305 Call CopyMem(sBox(4), m_sBox(1, ERxorK(6), ERxorK(7), ERxorK(8), ERxorK(9), ERxorK(10), ERxorK(11)), 4) 306 Call CopyMem(sBox(8), m_sBox(2, ERxorK(12), ERxorK(13), ERxorK(14), ERxorK(15), ERxorK(16), ERxorK(17)), 4) 307 Call CopyMem(sBox(12), m_sBox(3, ERxorK(18), ERxorK(19), ERxorK(20), ERxorK(21), ERxorK(22), ERxorK(23)), 4) 308 Call CopyMem(sBox(16), m_sBox(4, ERxorK(24), ERxorK(25), ERxorK(26), ERxorK(27), ERxorK(28), ERxorK(29)), 4) 309 Call CopyMem(sBox(20), m_sBox(5, ERxorK(30), ERxorK(31), ERxorK(32), ERxorK(33), ERxorK(34), ERxorK(35)), 4) 310 Call CopyMem(sBox(24), m_sBox(6, ERxorK(36), ERxorK(37), ERxorK(38), ERxorK(39), ERxorK(40), ERxorK(41)), 4) 311 Call CopyMem(sBox(28), m_sBox(7, ERxorK(42), ERxorK(43), ERxorK(44), ERxorK(45), ERxorK(46), ERxorK(47)), 4) 312 313 'L[i] xor P(R[i]) 314 LiRi(0) = L(0) Xor sBox(15) 315 LiRi(1) = L(1) Xor sBox(6) 316 LiRi(2) = L(2) Xor sBox(19) 317 LiRi(3) = L(3) Xor sBox(20) 318 LiRi(4) = L(4) Xor sBox(28) 319 LiRi(5) = L(5) Xor sBox(11) 320 LiRi(6) = L(6) Xor sBox(27) 321 LiRi(7) = L(7) Xor sBox(16) 322 LiRi(8) = L(8) Xor sBox(0) 323 LiRi(9) = L(9) Xor sBox(14) 324 LiRi(10) = L(10) Xor sBox(22) 325 LiRi(11) = L(11) Xor sBox(25) 326 LiRi(12) = L(12) Xor sBox(4) 327 LiRi(13) = L(13) Xor sBox(17) 328 LiRi(14) = L(14) Xor sBox(30) 329 LiRi(15) = L(15) Xor sBox(9) 330 LiRi(16) = L(16) Xor sBox(1) 331 LiRi(17) = L(17) Xor sBox(7) 332 LiRi(18) = L(18) Xor sBox(23) 333 LiRi(19) = L(19) Xor sBox(13) 334 LiRi(20) = L(20) Xor sBox(31) 335 LiRi(21) = L(21) Xor sBox(26) 336 LiRi(22) = L(22) Xor sBox(2) 337 LiRi(23) = L(23) Xor sBox(8) 338 LiRi(24) = L(24) Xor sBox(18) 339 LiRi(25) = L(25) Xor sBox(12) 340 LiRi(26) = L(26) Xor sBox(29) 341 LiRi(27) = L(27) Xor sBox(5) 342 LiRi(28) = L(28) Xor sBox(21) 343 LiRi(29) = L(29) Xor sBox(10) 344 LiRi(30) = L(30) Xor sBox(3) 345 LiRi(31) = L(31) Xor sBox(24) 346 347 'Prepare for next round 348 Call CopyMem(L(0), R(0), 32) 349 Call CopyMem(R(0), LiRi(0), 32) 350 Next 351 352 'Concatenate R[]L[] 353 Call CopyMem(RL(0), R(0), 32) 354 Call CopyMem(RL(32), L(0), 32) 355 356 'Apply the invIP permutation 357 For A = 0 To 63 358 BinBlock(A) = RL(m_IPInv(A)) 359 Next 360 361 'Convert the binaries into a byte array 362 Call Bin2Byte(BinBlock(), 8, BlockData()) 363 364 End Sub 365 366 Public Sub EncryptByte(ByteArray() As Byte, Optional Key As String) 367 368 Dim A As Long 369 Dim Offset As Long 370 Dim OrigLen As Long 371 Dim CipherLen As Long 372 Dim CurrPercent As Long 373 Dim NextPercent As Long 374 Dim CurrBlock(0 To 7) As Byte 375 Dim CipherBlock(0 To 7) As Byte 376 377 'Set the key if provided 378 '设置key 这里应该和c#里面是一样的 379 If (Len(Key) > 0) Then Me.Key = Key 380 381 'Get the size of the original array 382 '得到要加密数据的长度 383 OrigLen = UBound(ByteArray) + 1 384 385 'First we add 12 bytes (4 bytes for the 386 'length and 8 bytes for the seed values 387 'for the CBC routine), and the ciphertext 388 'must be a multiple of 8 bytes 389 '不明白这里为什么要加12 390 'CipherLen = OrigLen + 12 391 CipherLen = IIf(OrigLen = 0, 8, OrigLen) 392 '加密字符串处理，不足8的倍数补齐 393 If (CipherLen Mod 8 <> 0) Then 394 CipherLen = CipherLen + 8 - (CipherLen Mod 8) 395 End If 396 '重新写需要加密的内容 397 ReDim Preserve ByteArray(CipherLen - 1) 398 399 '参数说明 400 'hpvDest 要移动的目标 401 'hpvSource 要复制的内容 402 'cbCopy 要复制的字节数 403 '不明白这里 是不是从bytearray(12)开始复制ByteArray(0)的origlen个字节 404 '这里不是很明白.. 405 'Call CopyMem(ByteArray(12), ByteArray(0), OrigLen) 406 Call CopyMem(ByteArray(0), ByteArray(0), OrigLen) 407 408 'Store the length descriptor in bytes [9-12] 409 '这里更不明白了.ByteArray 8-11 是做什么用的？ 这个OrigLen是做什么的，和复制内存有关系吗？ 410 ' 把origLen存储到8-11位 411 '' Call CopyMem(ByteArray(8), OrigLen, 4) 412 413 'Store a block of random data in bytes [1-8], 414 'these work as seed values for the CBC routine 415 'and is used to produce different ciphertext 416 'even when encrypting the same data with the 417 'same key) 418 ' Call Randomize 419 ' '这里的问题同上..不明白第二个参数是怎么回事。。一个long型数据有什么用 420 '把随机数存储到ByteArray数组 421 ' Call CopyMem(ByteArray(0), CLng(2147483647 * Rnd), 4) 422 ' Call CopyMem(ByteArray(4), CLng(2147483647 * Rnd), 4) 423 ''''' 424 425 'Encrypt the data in 64-bit blocks 426 '加密数据 427 For Offset = 0 To (CipherLen - 1) Step 8 428 'Get the next block of plaintext 429 '依次从ByteArray中取出8位数据，复制到CurrBlock() 430 Call CopyMem(CurrBlock(0), ByteArray(Offset), 8) 431 432 'XOR the plaintext with the previous 433 'ciphertext (CBC, Cipher-Block Chaining) 434 '下面这个循环不明白是做什么的。。 435 For A = 0 To 7 436 CurrBlock(A) = CurrBlock(A) Xor CipherBlock(A) 437 Next 438 439 'Encrypt the block 440 '加密字节数据. 这是标准的加密方法吗？c#里有一个iv和一个key。为什么vb里没有设置iv的地方呢？ 441 '这里说的iv，请看Module1里的代码，其中代码为C#加密源码，下面两个值 442 ' private string iv="12345678"; 443 ' private string key="12345678"; 444 Call EncryptBlock(CurrBlock()) 445 446 'Store the block 447 '将加密后的内容存储回ByteArray() 448 Call CopyMem(ByteArray(Offset), CurrBlock(0), 8) 449 450 'Store the cipherblock (for CBC) 451 '这句不明白什么意思..应该是没用吧？ 452 ' Call CopyMem(CipherBlock(0), CurrBlock(0), 8) 453 Next 454 End Sub 455 Public Sub DecryptByte(ByteArray() As Byte, Optional Key As String) 456 457 Dim A As Long 458 Dim Offset As Long 459 Dim OrigLen As Long 460 Dim CipherLen As Long 461 Dim CurrPercent As Long 462 Dim NextPercent As Long 463 Dim CurrBlock(0 To 7) As Byte 464 Dim CipherBlock(0 To 7) As Byte 465 466 'Set the new key if provided 467 If (Len(Key) > 0) Then Me.Key = Key 468 469 'Get the size of the ciphertext 470 CipherLen = UBound(ByteArray) + 1 471 472 'Decrypt the data in 64-bit blocks 473 For Offset = 0 To (CipherLen - 1) Step 8 474 'Get the next block of ciphertext 475 Call CopyMem(CurrBlock(0), ByteArray(Offset), 8) 476 477 'Decrypt the block 478 Call DecryptBlock(CurrBlock()) 479 480 'XOR with the previous cipherblock 481 For A = 0 To 7 482 CurrBlock(A) = CurrBlock(A) Xor CipherBlock(A) 483 Next 484 485 'Store the current ciphertext to use 486 'XOR with the next block plaintext 487 ' Call CopyMem(CipherBlock(0), ByteArray(Offset), 8) 488 489 'Store the block 490 Call CopyMem(ByteArray(Offset), CurrBlock(0), 8) 491 492 'Update the progress if neccessary 493 ''' If (Offset >= NextPercent) Then 494 ''' CurrPercent = Int((Offset / CipherLen) * 100) 495 ''' NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1 496 ''' RaiseEvent Progress(CurrPercent) 497 ''' End If 498 Next 499 500 'Get the size of the original array 501 ' Call CopyMem(OrigLen, ByteArray(8), 4) 502 503 'Make sure OrigLen is a reasonable value, 504 'if we used the wrong key the next couple 505 'of statements could be dangerous (GPF) 506 ' If (CipherLen - OrigLen > 19) Or (CipherLen - OrigLen < 12) Then 507 ' Call Err.Raise(vbObjectError, , "Incorrect size descriptor in DES decryption") 508 ' End If 509 510 'Resize the bytearray to hold only the plaintext 511 'and not the extra information added by the 512 'encryption routine 513 ' Call CopyMem(ByteArray(0), ByteArray(12), OrigLen) 514 ' ReDim Preserve ByteArray(OrigLen - 1) 515 516 'Make sure we return a 100% progress 517 '' If (CurrPercent <> 100) Then RaiseEvent Progress(100) 518 519 End Sub 520 Public Sub EncryptFile(SourceFile As String, DestFile As String, Optional Key As String) 521 522 Dim Filenr As Integer 523 Dim ByteArray() As Byte 524 525 ' 'Make sure the source file do exist 526 ' If (Not FileExist(SourceFile)) Then 527 ' Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).") 528 ' Exit Sub 529 ' End If 530 ' 531 'Open the source file and read the content 532 'into a bytearray to pass onto encryption 533 Filenr = FreeFile 534 Open SourceFile For Binary As #Filenr 535 ReDim ByteArray(0 To LOF(Filenr) - 1) 536 Get #Filenr, , ByteArray() 537 Close #Filenr 538 539 'Encrypt the bytearray 540 Call EncryptByte(ByteArray(), Key) 541 542 'If the destination file already exist we need 543 'to delete it since opening it for binary use 544 'will preserve it if it already exist 545 ' If (FileExist(DestFile)) Then Kill DestFile 546 547 'Store the encrypted data in the destination file 548 Filenr = FreeFile 549 Open DestFile For Binary As #Filenr 550 Put #Filenr, , ByteArray() 551 Close #Filenr 552 553 End Sub 554 Public Sub DecryptFile(SourceFile As String, DestFile As String, Optional Key As String) 555 556 Dim Filenr As Integer 557 Dim ByteArray() As Byte 558 559 'Make sure the source file do exist 560 ' If (Not FileExist(SourceFile)) Then 561 ' Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).") 562 ' Exit Sub 563 ' End If 564 565 'Open the source file and read the content 566 'into a bytearray to decrypt 567 Filenr = FreeFile 568 Open SourceFile For Binary As #Filenr 569 ReDim ByteArray(0 To LOF(Filenr) - 1) 570 Get #Filenr, , ByteArray() 571 Close #Filenr 572 573 'Decrypt the bytearray 574 Call DecryptByte(ByteArray(), Key) 575 576 'If the destination file already exist we need 577 'to delete it since opening it for binary use 578 'will preserve it if it already exist 579 ' If (FileExist(DestFile)) Then Kill DestFile 580 581 'Store the decrypted data in the destination file 582 Filenr = FreeFile 583 Open DestFile For Binary As #Filenr 584 Put #Filenr, , ByteArray() 585 Close #Filenr 586 587 End Sub 588 589 Private Function EncodeBase64(ByRef arrData() As Byte) As String 590 591 592 593 Dim objXML As MSXML2.DOMDocument 594 Dim objNode As MSXML2.IXMLDOMElement 595 596 ' help from MSXML 597 Set objXML = New MSXML2.DOMDocument 598 599 ' byte array to base64 600 Set objNode = objXML.createElement("b64") 601 objNode.dataType = "bin.base64" 602 objNode.nodeTypedValue = arrData 603 EncodeBase64 = objNode.Text 604 605 606 607 ' thanks, bye 608 Set objNode = Nothing 609 Set objXML = Nothing 610 611 612 613 End Function 614 615 616 617 Private Function DecodeBase64(ByVal strData As String) As Byte() 618 619 620 621 Dim objXML As MSXML2.DOMDocument 622 Dim objNode As MSXML2.IXMLDOMElement 623 624 ' help from MSXML 625 Set objXML = New MSXML2.DOMDocument 626 Set objNode = objXML.createElement("b64") 627 objNode.dataType = "bin.base64" 628 objNode.Text = strData 629 DecodeBase64 = objNode.nodeTypedValue 630 631 ' thanks, bye 632 Set objNode = Nothing 633 Set objXML = Nothing 634 635 636 637 End Function 638 Public Function EncryptString(Text As String, Optional Key As String) As String 639 640 Dim ByteArray() As Byte 641 'Convert the text into a byte array 642 ByteArray() = StrConv(Text, vbFromUnicode) 643 'ByteArray() = DecodeBase64(Text) 644 ''''' byteA() = StrConv(Text, vbFromUnicode) 645 ''''' 'ByteArray() = DecodeBase64(Text) 646 ''''' Dim ByteArray() As Byte 647 ''''' ReDim ByteArray((UBound(byteA) + 1) * 2 - 1) 648 ''''' Dim i As Integer 649 ''''' For i = 0 To UBound(byteA) 650 ''''' ByteArray(i * 2) = byteA(i) 651 ''''' ByteArray(i * 2 + 1) = 0 652 ''''' Next i 653 'Encrypt the byte array 654 Call EncryptByte(ByteArray(), Key) 655 656 'Convert the byte array back to a string 657 ' EncryptString = StrConv(ByteArray(), vbUnicode) 658 EncryptString = EncodeBase64(ByteArray()) 659 End Function 660 661 Public Function DecryptString(Text As String, Optional Key As String) As String 662 663 Dim ByteArray() As Byte 664 665 'Convert the text into a byte array 666 ' ByteArray() = StrConv(Text, vbFromUnicode) 667 ByteArray() = DecodeBase64(Text) 668 669 'Encrypt the byte array 670 Call DecryptByte(ByteArray(), Key) 671 672 'Convert the byte array back to a string EncodeBase64(ByteArray()) ' 673 DecryptString = StrConv(ByteArray(), vbUnicode) 674 675 End Function 676 677 678 Public Property Let Key(New_Value As String) 679 680 Dim A As Long 681 Dim i As Long 682 Dim C(0 To 27) As Byte 683 Dim D(0 To 27) As Byte 684 Dim K(0 To 55) As Byte 685 Dim CD(0 To 55) As Byte 686 Dim Temp(0 To 1) As Byte 687 Dim KeyBin(0 To 63) As Byte 688 Dim KeySchedule(0 To 63) As Byte 689 690 'Do nothing if the key is buffered 691 If (m_KeyValue = New_Value) Then Exit Property 692 693 'Store a string value of the buffered key 694 m_KeyValue = New_Value 695 696 'Convert the key to a binary array 697 Call Byte2Bin(StrConv(New_Value, vbFromUnicode), IIf(Len(New_Value) > 8, 8, Len(New_Value)), KeyBin()) 698 699 'Apply the PC-2 permutation 700 For A = 0 To 55 701 KeySchedule(A) = KeyBin(m_PC1(A)) 702 Next 703 704 'Split keyschedule into two halves, C[] and D[] 705 Call CopyMem(C(0), KeySchedule(0), 28) 706 Call CopyMem(D(0), KeySchedule(28), 28) 707 708 'Calculate the key schedule (16 subkeys) 709 For i = 1 To 16 710 'Perform one or two cyclic left shifts on 711 'both C[i-1] and D[i-1] to get C[i] and D[i] 712 Call CopyMem(Temp(0), C(0), m_LeftShifts(i)) 713 Call CopyMem(C(0), C(m_LeftShifts(i)), 28 - m_LeftShifts(i)) 714 Call CopyMem(C(28 - m_LeftShifts(i)), Temp(0), m_LeftShifts(i)) 715 Call CopyMem(Temp(0), D(0), m_LeftShifts(i)) 716 Call CopyMem(D(0), D(m_LeftShifts(i)), 28 - m_LeftShifts(i)) 717 Call CopyMem(D(28 - m_LeftShifts(i)), Temp(0), m_LeftShifts(i)) 718 719 'Concatenate C[] and D[] 720 Call CopyMem(CD(0), C(0), 28) 721 Call CopyMem(CD(28), D(0), 28) 722 723 'Apply the PC-2 permutation and store 724 'the calculated subkey 725 For A = 0 To 47 726 m_Key(A, i) = CD(m_PC2(A)) 727 Next 728 Next 729 730 End Property 731 Private Sub Class_Initialize() 732 733 Dim i As Long 734 Dim vE As Variant 735 Dim vP As Variant 736 Dim vIP As Variant 737 Dim vPC1 As Variant 738 Dim vPC2 As Variant 739 Dim vIPInv As Variant 740 Dim vSbox(0 To 7) As Variant 741 742 'Initialize the permutation IP 743 vIP = Array(58, 50, 42, 34, 26, 18, 10, 2, _ 744 60, 52, 44, 36, 28, 20, 12, 4, _ 745 62, 54, 46, 38, 30, 22, 14, 6, _ 746 64, 56, 48, 40, 32, 24, 16, 8, _ 747 57, 49, 41, 33, 25, 17, 9, 1, _ 748 59, 51, 43, 35, 27, 19, 11, 3, _ 749 61, 53, 45, 37, 29, 21, 13, 5, _ 750 63, 55, 47, 39, 31, 23, 15, 7) 751 752 'Create the permutation IP 753 For i = LBound(vIP) To UBound(vIP) 754 m_IP(i) = (vIP(i) - 1) 755 Next 756 757 'Initialize the expansion function E 758 vE = Array(32, 1, 2, 3, 4, 5, _ 759 4, 5, 6, 7, 8, 9, _ 760 8, 9, 10, 11, 12, 13, _ 761 12, 13, 14, 15, 16, 17, _ 762 16, 17, 18, 19, 20, 21, _ 763 20, 21, 22, 23, 24, 25, _ 764 24, 25, 26, 27, 28, 29, _ 765 28, 29, 30, 31, 32, 1) 766 767 'Create the expansion array 768 For i = LBound(vE) To UBound(vE) 769 m_E(i) = (vE(i) - 1) 770 Next 771 772 'Initialize the PC1 function 773 vPC1 = Array(57, 49, 41, 33, 25, 17, 9, _ 774 1, 58, 50, 42, 34, 26, 18, _ 775 10, 2, 59, 51, 43, 35, 27, _ 776 19, 11, 3, 60, 52, 44, 36, _ 777 63, 55, 47, 39, 31, 23, 15, _ 778 7, 62, 54, 46, 38, 30, 22, _ 779 14, 6, 61, 53, 45, 37, 29, _ 780 21, 13, 5, 28, 20, 12, 4) 781 782 'Create the PC1 function 783 For i = LBound(vPC1) To UBound(vPC1) 784 m_PC1(i) = (vPC1(i) - 1) 785 Next 786 787 'Initialize the PC2 function 788 vPC2 = Array(14, 17, 11, 24, 1, 5, _ 789 3, 28, 15, 6, 21, 10, _ 790 23, 19, 12, 4, 26, 8, _ 791 16, 7, 27, 20, 13, 2, _ 792 41, 52, 31, 37, 47, 55, _ 793 30, 40, 51, 45, 33, 48, _ 794 44, 49, 39, 56, 34, 53, _ 795 46, 42, 50, 36, 29, 32) 796 797 'Create the PC2 function 798 For i = LBound(vPC2) To UBound(vPC2) 799 m_PC2(i) = (vPC2(i) - 1) 800 Next 801 802 'Initialize the inverted IP 803 vIPInv = Array(40, 8, 48, 16, 56, 24, 64, 32, _ 804 39, 7, 47, 15, 55, 23, 63, 31, _ 805 38, 6, 46, 14, 54, 22, 62, 30, _ 806 37, 5, 45, 13, 53, 21, 61, 29, _ 807 36, 4, 44, 12, 52, 20, 60, 28, _ 808 35, 3, 43, 11, 51, 19, 59, 27, _ 809 34, 2, 42, 10, 50, 18, 58, 26, _ 810 33, 1, 41, 9, 49, 17, 57, 25) 811 812 'Create the inverted IP 813 For i = LBound(vIPInv) To UBound(vIPInv) 814 m_IPInv(i) = (vIPInv(i) - 1) 815 Next 816 817 'Initialize permutation P 818 vP = Array(16, 7, 20, 21, _ 819 29, 12, 28, 17, _ 820 1, 15, 23, 26, _ 821 5, 18, 31, 10, _ 822 2, 8, 24, 14, _ 823 32, 27, 3, 9, _ 824 19, 13, 30, 6, _ 825 22, 11, 4, 25) 826 827 'Create P 828 For i = LBound(vP) To UBound(vP) 829 m_P(i) = (vP(i) - 1) 830 Next 831 832 'Initialize the leftshifts array 833 For i = 1 To 16 834 Select Case i 835 Case 1, 2, 9, 16 836 m_LeftShifts(i) = 1 837 Case Else 838 m_LeftShifts(i) = 2 839 End Select 840 Next 841 842 'Initialize the eight s-boxes 843 vSbox(0) = Array(14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7, _ 844 0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8, _ 845 4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0, _ 846 15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13) 847 848 vSbox(1) = Array(15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10, _ 849 3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5, _ 850 0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15, _ 851 13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9) 852 853 vSbox(2) = Array(10, 0, 9, 14, 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8, _ 854 13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1, _ 855 13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7, _ 856 1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12) 857 858 vSbox(3) = Array(7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15, _ 859 13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9, _ 860 10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4, _ 861 3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14) 862 863 vSbox(4) = Array(2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9, _ 864 14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6, _ 865 4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14, _ 866 11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3) 867 868 vSbox(5) = Array(12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11, _ 869 10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8, _ 870 9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6, _ 871 4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13) 872 873 vSbox(6) = Array(4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1, _ 874 13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6, _ 875 1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2, _ 876 6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12) 877 878 vSbox(7) = Array(13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7, _ 879 1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2, _ 880 7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8, _ 881 2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11) 882 883 Dim lBox As Long 884 Dim lRow As Long 885 Dim lColumn As Long 886 Dim TheByte(0) As Byte 887 Dim TheBin(0 To 7) As Byte 888 Dim A As Byte, B As Byte, C As Byte, D As Byte, e As Byte, F As Byte 889 890 'Create an optimized version of the s-boxes 891 'this is not in the standard but much faster 892 'than calculating the Row/Column index later 893 For lBox = 0 To 7 894 For A = 0 To 1 895 For B = 0 To 1 896 For C = 0 To 1 897 For D = 0 To 1 898 For e = 0 To 1 899 For F = 0 To 1 900 lRow = A * 2 + F 901 lColumn = B * 8 + C * 4 + D * 2 + e 902 TheByte(0) = vSbox(lBox)(lRow * 16 + lColumn) 903 Call Byte2Bin(TheByte(), 1, TheBin()) 904 Call CopyMem(m_sBox(lBox, A, B, C, D, e, F), TheBin(4), 4) 905 Next 906 Next 907 Next 908 Next 909 Next 910 Next 911 Next 912 913 End Sub
[转] VB6.0 DES （ECB 模式）加解密
猜你喜欢
转载自www.cnblogs.com/PengRay0221/p/9025375.html
今日推荐
周排行