Public Function strAnsi2Unicode(ByVal asContents As String) As String '将Ansi编码的字符串，转换成Unicode编码的字符串 Dim len1, i As Long Dim varchar As String Dim varasc As LongstrAnsi2Unicode = "" len1 = LenB(asContents) If len1 = 0 Then Exit Function For i = 1 To len1 varchar = MidB(asContents, i, 1) varasc = AscB(varchar) If varasc > 127 Then strAnsi2Unicode = strAnsi2Unicode & Chr(AscW(MidB(asContents, i + 1, 1) & varchar)) i = i + 1 Else strAnsi2Unicode = strAnsi2Unicode & Chr(varasc) End If Next End Function
我要的是byteArray转换成Unicode格式字符串，你给的好像不是阿。有没有人知道呢？
是这样的。我再写des加密算法。我用的是网上下载的一个类包。其中加密、解密一个文件都没用问题，可就是加密、解密字符串的时候出现问题了。我看了一下源程序，问题就出在byteArray转换成Unicode格式字符串上了，源程序太长，我只能帖一部分 Public Function EncryptString(Text As String, Optional Key As String) As String Dim ByteArray() As Byte
'Convert the text into a byte array ByteArray() = StrConv(Text, vbFromUnicode)
'Encrypt the byte array Call EncryptByte(ByteArray(), Key)'这一部分的源码太长
'Convert the byte array back to a string EncryptString = StrConv(ByteArray(), vbUnicode)End Function 这个是加密部分Public Function DecryptString(Text As String, Optional Key As String) As String Dim ByteArray() As Byte
'Convert the text into a byte array ByteArray() = StrConv(Text, vbFromUnicode)
'Encrypt the byte array Call DecryptByte(ByteArray(), Key)
'Convert the byte array back to a string DecryptString = StrConv(ByteArray(), vbUnicode)End Function 这个是解密部分
是在什么系统下，98下应该没有这个问题，2000下遇到过，可以用CopyMemory试试：声明 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)另外： Dim ByteArray() As Byte
'Convert the text into a byte array ByteArray() = StrConv(Text, vbFromUnicode)
'Encrypt the byte array Call EncryptByte(ByteArray(), Key)'这一部分的源码太长
'Convert the byte array back to a string EncryptString = StrConv(ByteArray(), vbUnicode)把ByteArray()后面的括号去掉试试
全部的 Option Explicit'For progress notifications Event Progress(Percent As Long)'Key-dependant Private m_Key(0 To 47, 1 To 16) As Byte'Buffered key value Private m_KeyValue As String'Values given in the DES standard Private m_E(0 To 63) As Byte Private m_P(0 To 31) As Byte Private m_IP(0 To 63) As Byte Private m_PC1(0 To 55) As Byte Private m_PC2(0 To 47) As Byte Private m_IPInv(0 To 63) As Byte Private m_EmptyArray(0 To 63) As Byte Private m_LeftShifts(1 To 16) As Byte 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 LongPrivate Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Static Sub Byte2Bin(ByteArray() As Byte, ByteLen As Long, BinaryArray() As Byte) Dim a As Long Dim ByteValue As Byte Dim BinLength As Long
'Clear the destination array, faster than 'setting the data to zero in the loop below Call CopyMem(BinaryArray(0), m_EmptyArray(0), ByteLen * 8)
'Add binary 1's where needed BinLength = 0 For a = 0 To (ByteLen - 1) ByteValue = ByteArray(a) If (ByteValue And 128) Then BinaryArray(BinLength) = 1 If (ByteValue And 64) Then BinaryArray(BinLength + 1) = 1 If (ByteValue And 32) Then BinaryArray(BinLength + 2) = 1 If (ByteValue And 16) Then BinaryArray(BinLength + 3) = 1 If (ByteValue And 8) Then BinaryArray(BinLength + 4) = 1 If (ByteValue And 4) Then BinaryArray(BinLength + 5) = 1 If (ByteValue And 2) Then BinaryArray(BinLength + 6) = 1 If (ByteValue And 1) Then BinaryArray(BinLength + 7) = 1 BinLength = BinLength + 8 NextEnd Sub Private Static Sub Bin2Byte(BinaryArray() As Byte, ByteLen As Long, ByteArray() As Byte) Dim a As Long Dim ByteValue As Byte Dim BinLength As Long
'Calculate byte values BinLength = 0 For a = 0 To (ByteLen - 1) ByteValue = 0 If (BinaryArray(BinLength) = 1) Then ByteValue = ByteValue + 128 If (BinaryArray(BinLength + 1) = 1) Then ByteValue = ByteValue + 64 If (BinaryArray(BinLength + 2) = 1) Then ByteValue = ByteValue + 32 If (BinaryArray(BinLength + 3) = 1) Then ByteValue = ByteValue + 16 If (BinaryArray(BinLength + 4) = 1) Then ByteValue = ByteValue + 8 If (BinaryArray(BinLength + 5) = 1) Then ByteValue = ByteValue + 4 If (BinaryArray(BinLength + 6) = 1) Then ByteValue = ByteValue + 2 If (BinaryArray(BinLength + 7) = 1) Then ByteValue = ByteValue + 1 ByteArray(a) = ByteValue BinLength = BinLength + 8 Next
End Sub Private Static Sub EncryptBlock(BlockData() As Byte) Dim a As Long Dim i As Long Dim L(0 To 31) As Byte Dim R(0 To 31) As Byte Dim RL(0 To 63) As Byte Dim sBox(0 To 31) As Byte Dim LiRi(0 To 31) As Byte Dim ERxorK(0 To 47) As Byte Dim BinBlock(0 To 63) As Byte
'Convert the block into a binary array '(I do believe this is the best solution 'in VB for the DES algorithm, but it is 'still slow as xxxx) Call Byte2Bin(BlockData(), 8, BinBlock())
'Apply the IP permutation and split the 'block into two halves, L[] and R[] For a = 0 To 31 L(a) = BinBlock(m_IP(a)) R(a) = BinBlock(m_IP(a + 32)) Next
'Prepare for next round Call CopyMem(L(0), R(0), 32) Call CopyMem(R(0), LiRi(0), 32) Next
'Concatenate R[]L[] Call CopyMem(RL(0), R(0), 32) Call CopyMem(RL(32), L(0), 32) 'Apply the invIP permutation For a = 0 To 63 BinBlock(a) = RL(m_IPInv(a)) Next
'Convert the binaries into a byte array Call Bin2Byte(BinBlock(), 8, BlockData())End Sub
Private Static Sub DecryptBlock(BlockData() As Byte) Dim a As Long Dim i As Long Dim L(0 To 31) As Byte Dim R(0 To 31) As Byte Dim RL(0 To 63) As Byte Dim sBox(0 To 31) As Byte Dim LiRi(0 To 31) As Byte Dim ERxorK(0 To 47) As Byte Dim BinBlock(0 To 63) As Byte
'Convert the block into a binary array '(I do believe this is the best solution 'in VB for the DES algorithm, but it is 'still slow as xxxx) Call Byte2Bin(BlockData(), 8, BinBlock())
'Apply the IP permutation and split the 'block into two halves, L[] and R[] For a = 0 To 31 L(a) = BinBlock(m_IP(a)) R(a) = BinBlock(m_IP(a + 32)) Next
'Prepare for next round Call CopyMem(L(0), R(0), 32) Call CopyMem(R(0), LiRi(0), 32) Next
'Concatenate R[]L[] Call CopyMem(RL(0), R(0), 32) Call CopyMem(RL(32), L(0), 32) 'Apply the invIP permutation For a = 0 To 63 BinBlock(a) = RL(m_IPInv(a)) Next
'Convert the binaries into a byte array Call Bin2Byte(BinBlock(), 8, BlockData())End SubPublic Sub EncryptByte(ByteArray() As Byte, Optional Key As String) Dim a As Long Dim Offset As Long Dim OrigLen As Long Dim CipherLen As Long Dim CurrPercent As Long Dim NextPercent As Long Dim CurrBlock(0 To 7) As Byte Dim CipherBlock(0 To 7) As Byte
'Set the key if provided If (Len(Key) > 0) Then Me.Key = Key
'Get the size of the original array OrigLen = UBound(ByteArray) + 1
'First we add 12 bytes (4 bytes for the 'length and 8 bytes for the seed values 'for the CBC routine), and the ciphertext 'must be a multiple of 8 bytes CipherLen = OrigLen + 12 If (CipherLen Mod 8 <> 0) Then CipherLen = CipherLen + 8 - (CipherLen Mod 8) End If ReDim Preserve ByteArray(CipherLen - 1) Call CopyMem(ByteArray(12), ByteArray(0), OrigLen)
'Store the length descriptor in bytes [9-12] Call CopyMem(ByteArray(8), OrigLen, 4)
'Store a block of random data in bytes [1-8], 'these work as seed values for the CBC routine 'and is used to produce different ciphertext 'even when encrypting the same data with the 'same key) Call Randomize Call CopyMem(ByteArray(0), CLng(2147483647 * Rnd), 4) Call CopyMem(ByteArray(4), CLng(2147483647 * Rnd), 4)
'Encrypt the data in 64-bit blocks For Offset = 0 To (CipherLen - 1) Step 8 'Get the next block of plaintext Call CopyMem(CurrBlock(0), ByteArray(Offset), 8)
'XOR the plaintext with the previous 'ciphertext (CBC, Cipher-Block Chaining) For a = 0 To 7 CurrBlock(a) = CurrBlock(a) Xor CipherBlock(a) Next
'Encrypt the block Call EncryptBlock(CurrBlock())
'Store the block Call CopyMem(ByteArray(Offset), CurrBlock(0), 8)
'Store the cipherblock (for CBC) Call CopyMem(CipherBlock(0), CurrBlock(0), 8)
'Update the progress if neccessary If (Offset >= NextPercent) Then CurrPercent = Int((Offset / CipherLen) * 100) NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1 RaiseEvent Progress(CurrPercent) End If Next
'Make sure we return a 100% progress If (CurrPercent <> 100) Then RaiseEvent Progress(100)End Sub
'将Ansi编码的字符串，转换成Unicode编码的字符串
Dim len1, i As Long
Dim varchar As String
Dim varasc As LongstrAnsi2Unicode = ""
len1 = LenB(asContents)
If len1 = 0 Then Exit Function
For i = 1 To len1
varchar = MidB(asContents, i, 1)
varasc = AscB(varchar)
If varasc > 127 Then
strAnsi2Unicode = strAnsi2Unicode & Chr(AscW(MidB(asContents, i + 1, 1) & varchar))
i = i + 1
Else
strAnsi2Unicode = strAnsi2Unicode & Chr(varasc)
End If
Next
End Function
Public Function EncryptString(Text As String, Optional Key As String) As String Dim ByteArray() As Byte
'Convert the text into a byte array
ByteArray() = StrConv(Text, vbFromUnicode)
'Encrypt the byte array
Call EncryptByte(ByteArray(), Key)'这一部分的源码太长
'Convert the byte array back to a string
EncryptString = StrConv(ByteArray(), vbUnicode)End Function
这个是加密部分Public Function DecryptString(Text As String, Optional Key As String) As String Dim ByteArray() As Byte
'Convert the text into a byte array
ByteArray() = StrConv(Text, vbFromUnicode)
'Encrypt the byte array
Call DecryptByte(ByteArray(), Key)
'Convert the byte array back to a string
DecryptString = StrConv(ByteArray(), vbUnicode)End Function
这个是解密部分
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)另外：
Dim ByteArray() As Byte
'Convert the text into a byte array
ByteArray() = StrConv(Text, vbFromUnicode)
'Encrypt the byte array
Call EncryptByte(ByteArray(), Key)'这一部分的源码太长
'Convert the byte array back to a string
EncryptString = StrConv(ByteArray(), vbUnicode)把ByteArray()后面的括号去掉试试
Option Explicit'For progress notifications
Event Progress(Percent As Long)'Key-dependant
Private m_Key(0 To 47, 1 To 16) As Byte'Buffered key value
Private m_KeyValue As String'Values given in the DES standard
Private m_E(0 To 63) As Byte
Private m_P(0 To 31) As Byte
Private m_IP(0 To 63) As Byte
Private m_PC1(0 To 55) As Byte
Private m_PC2(0 To 47) As Byte
Private m_IPInv(0 To 63) As Byte
Private m_EmptyArray(0 To 63) As Byte
Private m_LeftShifts(1 To 16) As Byte
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 LongPrivate Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Static Sub Byte2Bin(ByteArray() As Byte, ByteLen As Long, BinaryArray() As Byte) Dim a As Long
Dim ByteValue As Byte
Dim BinLength As Long
'Clear the destination array, faster than
'setting the data to zero in the loop below
Call CopyMem(BinaryArray(0), m_EmptyArray(0), ByteLen * 8)
'Add binary 1's where needed
BinLength = 0
For a = 0 To (ByteLen - 1)
ByteValue = ByteArray(a)
If (ByteValue And 128) Then BinaryArray(BinLength) = 1
If (ByteValue And 64) Then BinaryArray(BinLength + 1) = 1
If (ByteValue And 32) Then BinaryArray(BinLength + 2) = 1
If (ByteValue And 16) Then BinaryArray(BinLength + 3) = 1
If (ByteValue And 8) Then BinaryArray(BinLength + 4) = 1
If (ByteValue And 4) Then BinaryArray(BinLength + 5) = 1
If (ByteValue And 2) Then BinaryArray(BinLength + 6) = 1
If (ByteValue And 1) Then BinaryArray(BinLength + 7) = 1
BinLength = BinLength + 8
NextEnd Sub
Private Static Sub Bin2Byte(BinaryArray() As Byte, ByteLen As Long, ByteArray() As Byte) Dim a As Long
Dim ByteValue As Byte
Dim BinLength As Long
'Calculate byte values
BinLength = 0
For a = 0 To (ByteLen - 1)
ByteValue = 0
If (BinaryArray(BinLength) = 1) Then ByteValue = ByteValue + 128
If (BinaryArray(BinLength + 1) = 1) Then ByteValue = ByteValue + 64
If (BinaryArray(BinLength + 2) = 1) Then ByteValue = ByteValue + 32
If (BinaryArray(BinLength + 3) = 1) Then ByteValue = ByteValue + 16
If (BinaryArray(BinLength + 4) = 1) Then ByteValue = ByteValue + 8
If (BinaryArray(BinLength + 5) = 1) Then ByteValue = ByteValue + 4
If (BinaryArray(BinLength + 6) = 1) Then ByteValue = ByteValue + 2
If (BinaryArray(BinLength + 7) = 1) Then ByteValue = ByteValue + 1
ByteArray(a) = ByteValue
BinLength = BinLength + 8
Next
End Sub
Private Static Sub EncryptBlock(BlockData() As Byte) Dim a As Long
Dim i As Long
Dim L(0 To 31) As Byte
Dim R(0 To 31) As Byte
Dim RL(0 To 63) As Byte
Dim sBox(0 To 31) As Byte
Dim LiRi(0 To 31) As Byte
Dim ERxorK(0 To 47) As Byte
Dim BinBlock(0 To 63) As Byte
'Convert the block into a binary array
'(I do believe this is the best solution
'in VB for the DES algorithm, but it is
'still slow as xxxx)
Call Byte2Bin(BlockData(), 8, BinBlock())
'Apply the IP permutation and split the
'block into two halves, L[] and R[]
For a = 0 To 31
L(a) = BinBlock(m_IP(a))
R(a) = BinBlock(m_IP(a + 32))
Next
'Apply the 16 subkeys on the block
For i = 1 To 16
'E(R[i]) xor K[i]
ERxorK(0) = R(31) Xor m_Key(0, i)
ERxorK(1) = R(0) Xor m_Key(1, i)
ERxorK(2) = R(1) Xor m_Key(2, i)
ERxorK(3) = R(2) Xor m_Key(3, i)
ERxorK(4) = R(3) Xor m_Key(4, i)
ERxorK(5) = R(4) Xor m_Key(5, i)
ERxorK(6) = R(3) Xor m_Key(6, i)
ERxorK(7) = R(4) Xor m_Key(7, i)
ERxorK(8) = R(5) Xor m_Key(8, i)
ERxorK(9) = R(6) Xor m_Key(9, i)
ERxorK(10) = R(7) Xor m_Key(10, i)
ERxorK(11) = R(8) Xor m_Key(11, i)
ERxorK(12) = R(7) Xor m_Key(12, i)
ERxorK(13) = R(8) Xor m_Key(13, i)
ERxorK(14) = R(9) Xor m_Key(14, i)
ERxorK(15) = R(10) Xor m_Key(15, i)
ERxorK(16) = R(11) Xor m_Key(16, i)
ERxorK(17) = R(12) Xor m_Key(17, i)
ERxorK(18) = R(11) Xor m_Key(18, i)
ERxorK(19) = R(12) Xor m_Key(19, i)
ERxorK(20) = R(13) Xor m_Key(20, i)
ERxorK(21) = R(14) Xor m_Key(21, i)
ERxorK(22) = R(15) Xor m_Key(22, i)
ERxorK(23) = R(16) Xor m_Key(23, i)
ERxorK(24) = R(15) Xor m_Key(24, i)
ERxorK(25) = R(16) Xor m_Key(25, i)
ERxorK(26) = R(17) Xor m_Key(26, i)
ERxorK(27) = R(18) Xor m_Key(27, i)
ERxorK(28) = R(19) Xor m_Key(28, i)
ERxorK(29) = R(20) Xor m_Key(29, i)
ERxorK(30) = R(19) Xor m_Key(30, i)
ERxorK(31) = R(20) Xor m_Key(31, i)
ERxorK(32) = R(21) Xor m_Key(32, i)
ERxorK(33) = R(22) Xor m_Key(33, i)
ERxorK(34) = R(23) Xor m_Key(34, i)
ERxorK(35) = R(24) Xor m_Key(35, i)
ERxorK(36) = R(23) Xor m_Key(36, i)
ERxorK(37) = R(24) Xor m_Key(37, i)
ERxorK(38) = R(25) Xor m_Key(38, i)
ERxorK(39) = R(26) Xor m_Key(39, i)
ERxorK(40) = R(27) Xor m_Key(40, i)
ERxorK(41) = R(28) Xor m_Key(41, i)
ERxorK(42) = R(27) Xor m_Key(42, i)
ERxorK(43) = R(28) Xor m_Key(43, i)
ERxorK(44) = R(29) Xor m_Key(44, i)
ERxorK(45) = R(30) Xor m_Key(45, i)
ERxorK(46) = R(31) Xor m_Key(46, i)
ERxorK(47) = R(0) Xor m_Key(47, i)
'Apply the s-boxes
Call CopyMem(sBox(0), m_sBox(0, ERxorK(0), ERxorK(1), ERxorK(2), ERxorK(3), ERxorK(4), ERxorK(5)), 4)
Call CopyMem(sBox(4), m_sBox(1, ERxorK(6), ERxorK(7), ERxorK(8), ERxorK(9), ERxorK(10), ERxorK(11)), 4)
Call CopyMem(sBox(8), m_sBox(2, ERxorK(12), ERxorK(13), ERxorK(14), ERxorK(15), ERxorK(16), ERxorK(17)), 4)
Call CopyMem(sBox(12), m_sBox(3, ERxorK(18), ERxorK(19), ERxorK(20), ERxorK(21), ERxorK(22), ERxorK(23)), 4)
Call CopyMem(sBox(16), m_sBox(4, ERxorK(24), ERxorK(25), ERxorK(26), ERxorK(27), ERxorK(28), ERxorK(29)), 4)
Call CopyMem(sBox(20), m_sBox(5, ERxorK(30), ERxorK(31), ERxorK(32), ERxorK(33), ERxorK(34), ERxorK(35)), 4)
Call CopyMem(sBox(24), m_sBox(6, ERxorK(36), ERxorK(37), ERxorK(38), ERxorK(39), ERxorK(40), ERxorK(41)), 4)
Call CopyMem(sBox(28), m_sBox(7, ERxorK(42), ERxorK(43), ERxorK(44), ERxorK(45), ERxorK(46), ERxorK(47)), 4)
'L[i] xor P(R[i])
LiRi(0) = L(0) Xor sBox(15)
LiRi(1) = L(1) Xor sBox(6)
LiRi(2) = L(2) Xor sBox(19)
LiRi(3) = L(3) Xor sBox(20)
LiRi(4) = L(4) Xor sBox(28)
LiRi(5) = L(5) Xor sBox(11)
LiRi(6) = L(6) Xor sBox(27)
LiRi(7) = L(7) Xor sBox(16)
LiRi(8) = L(8) Xor sBox(0)
LiRi(9) = L(9) Xor sBox(14)
LiRi(10) = L(10) Xor sBox(22)
LiRi(11) = L(11) Xor sBox(25)
LiRi(12) = L(12) Xor sBox(4)
LiRi(13) = L(13) Xor sBox(17)
LiRi(14) = L(14) Xor sBox(30)
LiRi(15) = L(15) Xor sBox(9)
LiRi(16) = L(16) Xor sBox(1)
LiRi(17) = L(17) Xor sBox(7)
LiRi(18) = L(18) Xor sBox(23)
LiRi(19) = L(19) Xor sBox(13)
LiRi(20) = L(20) Xor sBox(31)
LiRi(21) = L(21) Xor sBox(26)
LiRi(22) = L(22) Xor sBox(2)
LiRi(23) = L(23) Xor sBox(8)
LiRi(24) = L(24) Xor sBox(18)
LiRi(25) = L(25) Xor sBox(12)
LiRi(26) = L(26) Xor sBox(29)
LiRi(27) = L(27) Xor sBox(5)
LiRi(28) = L(28) Xor sBox(21)
LiRi(29) = L(29) Xor sBox(10)
LiRi(30) = L(30) Xor sBox(3)
LiRi(31) = L(31) Xor sBox(24)
'Prepare for next round
Call CopyMem(L(0), R(0), 32)
Call CopyMem(R(0), LiRi(0), 32)
Next
'Concatenate R[]L[]
Call CopyMem(RL(0), R(0), 32)
Call CopyMem(RL(32), L(0), 32) 'Apply the invIP permutation
For a = 0 To 63
BinBlock(a) = RL(m_IPInv(a))
Next
'Convert the binaries into a byte array
Call Bin2Byte(BinBlock(), 8, BlockData())End Sub
Dim i As Long
Dim L(0 To 31) As Byte
Dim R(0 To 31) As Byte
Dim RL(0 To 63) As Byte
Dim sBox(0 To 31) As Byte
Dim LiRi(0 To 31) As Byte
Dim ERxorK(0 To 47) As Byte
Dim BinBlock(0 To 63) As Byte
'Convert the block into a binary array
'(I do believe this is the best solution
'in VB for the DES algorithm, but it is
'still slow as xxxx)
Call Byte2Bin(BlockData(), 8, BinBlock())
'Apply the IP permutation and split the
'block into two halves, L[] and R[]
For a = 0 To 31
L(a) = BinBlock(m_IP(a))
R(a) = BinBlock(m_IP(a + 32))
Next
'Apply the 16 subkeys on the block
For i = 16 To 1 Step -1
'E(R[i]) xor K[i]
ERxorK(0) = R(31) Xor m_Key(0, i)
ERxorK(1) = R(0) Xor m_Key(1, i)
ERxorK(2) = R(1) Xor m_Key(2, i)
ERxorK(3) = R(2) Xor m_Key(3, i)
ERxorK(4) = R(3) Xor m_Key(4, i)
ERxorK(5) = R(4) Xor m_Key(5, i)
ERxorK(6) = R(3) Xor m_Key(6, i)
ERxorK(7) = R(4) Xor m_Key(7, i)
ERxorK(8) = R(5) Xor m_Key(8, i)
ERxorK(9) = R(6) Xor m_Key(9, i)
ERxorK(10) = R(7) Xor m_Key(10, i)
ERxorK(11) = R(8) Xor m_Key(11, i)
ERxorK(12) = R(7) Xor m_Key(12, i)
ERxorK(13) = R(8) Xor m_Key(13, i)
ERxorK(14) = R(9) Xor m_Key(14, i)
ERxorK(15) = R(10) Xor m_Key(15, i)
ERxorK(16) = R(11) Xor m_Key(16, i)
ERxorK(17) = R(12) Xor m_Key(17, i)
ERxorK(18) = R(11) Xor m_Key(18, i)
ERxorK(19) = R(12) Xor m_Key(19, i)
ERxorK(20) = R(13) Xor m_Key(20, i)
ERxorK(21) = R(14) Xor m_Key(21, i)
ERxorK(22) = R(15) Xor m_Key(22, i)
ERxorK(23) = R(16) Xor m_Key(23, i)
ERxorK(24) = R(15) Xor m_Key(24, i)
ERxorK(25) = R(16) Xor m_Key(25, i)
ERxorK(26) = R(17) Xor m_Key(26, i)
ERxorK(27) = R(18) Xor m_Key(27, i)
ERxorK(28) = R(19) Xor m_Key(28, i)
ERxorK(29) = R(20) Xor m_Key(29, i)
ERxorK(30) = R(19) Xor m_Key(30, i)
ERxorK(31) = R(20) Xor m_Key(31, i)
ERxorK(32) = R(21) Xor m_Key(32, i)
ERxorK(33) = R(22) Xor m_Key(33, i)
ERxorK(34) = R(23) Xor m_Key(34, i)
ERxorK(35) = R(24) Xor m_Key(35, i)
ERxorK(36) = R(23) Xor m_Key(36, i)
ERxorK(37) = R(24) Xor m_Key(37, i)
ERxorK(38) = R(25) Xor m_Key(38, i)
ERxorK(39) = R(26) Xor m_Key(39, i)
ERxorK(40) = R(27) Xor m_Key(40, i)
ERxorK(41) = R(28) Xor m_Key(41, i)
ERxorK(42) = R(27) Xor m_Key(42, i)
ERxorK(43) = R(28) Xor m_Key(43, i)
ERxorK(44) = R(29) Xor m_Key(44, i)
ERxorK(45) = R(30) Xor m_Key(45, i)
ERxorK(46) = R(31) Xor m_Key(46, i)
ERxorK(47) = R(0) Xor m_Key(47, i)
'Apply the s-boxes
Call CopyMem(sBox(0), m_sBox(0, ERxorK(0), ERxorK(1), ERxorK(2), ERxorK(3), ERxorK(4), ERxorK(5)), 4)
Call CopyMem(sBox(4), m_sBox(1, ERxorK(6), ERxorK(7), ERxorK(8), ERxorK(9), ERxorK(10), ERxorK(11)), 4)
Call CopyMem(sBox(8), m_sBox(2, ERxorK(12), ERxorK(13), ERxorK(14), ERxorK(15), ERxorK(16), ERxorK(17)), 4)
Call CopyMem(sBox(12), m_sBox(3, ERxorK(18), ERxorK(19), ERxorK(20), ERxorK(21), ERxorK(22), ERxorK(23)), 4)
Call CopyMem(sBox(16), m_sBox(4, ERxorK(24), ERxorK(25), ERxorK(26), ERxorK(27), ERxorK(28), ERxorK(29)), 4)
Call CopyMem(sBox(20), m_sBox(5, ERxorK(30), ERxorK(31), ERxorK(32), ERxorK(33), ERxorK(34), ERxorK(35)), 4)
Call CopyMem(sBox(24), m_sBox(6, ERxorK(36), ERxorK(37), ERxorK(38), ERxorK(39), ERxorK(40), ERxorK(41)), 4)
Call CopyMem(sBox(28), m_sBox(7, ERxorK(42), ERxorK(43), ERxorK(44), ERxorK(45), ERxorK(46), ERxorK(47)), 4)
'L[i] xor P(R[i])
LiRi(0) = L(0) Xor sBox(15)
LiRi(1) = L(1) Xor sBox(6)
LiRi(2) = L(2) Xor sBox(19)
LiRi(3) = L(3) Xor sBox(20)
LiRi(4) = L(4) Xor sBox(28)
LiRi(5) = L(5) Xor sBox(11)
LiRi(6) = L(6) Xor sBox(27)
LiRi(7) = L(7) Xor sBox(16)
LiRi(8) = L(8) Xor sBox(0)
LiRi(9) = L(9) Xor sBox(14)
LiRi(10) = L(10) Xor sBox(22)
LiRi(11) = L(11) Xor sBox(25)
LiRi(12) = L(12) Xor sBox(4)
LiRi(13) = L(13) Xor sBox(17)
LiRi(14) = L(14) Xor sBox(30)
LiRi(15) = L(15) Xor sBox(9)
LiRi(16) = L(16) Xor sBox(1)
LiRi(17) = L(17) Xor sBox(7)
LiRi(18) = L(18) Xor sBox(23)
LiRi(19) = L(19) Xor sBox(13)
LiRi(20) = L(20) Xor sBox(31)
LiRi(21) = L(21) Xor sBox(26)
LiRi(22) = L(22) Xor sBox(2)
LiRi(23) = L(23) Xor sBox(8)
LiRi(24) = L(24) Xor sBox(18)
LiRi(25) = L(25) Xor sBox(12)
LiRi(26) = L(26) Xor sBox(29)
LiRi(27) = L(27) Xor sBox(5)
LiRi(28) = L(28) Xor sBox(21)
LiRi(29) = L(29) Xor sBox(10)
LiRi(30) = L(30) Xor sBox(3)
LiRi(31) = L(31) Xor sBox(24)
'Prepare for next round
Call CopyMem(L(0), R(0), 32)
Call CopyMem(R(0), LiRi(0), 32)
Next
'Concatenate R[]L[]
Call CopyMem(RL(0), R(0), 32)
Call CopyMem(RL(32), L(0), 32) 'Apply the invIP permutation
For a = 0 To 63
BinBlock(a) = RL(m_IPInv(a))
Next
'Convert the binaries into a byte array
Call Bin2Byte(BinBlock(), 8, BlockData())End SubPublic Sub EncryptByte(ByteArray() As Byte, Optional Key As String) Dim a As Long
Dim Offset As Long
Dim OrigLen As Long
Dim CipherLen As Long
Dim CurrPercent As Long
Dim NextPercent As Long
Dim CurrBlock(0 To 7) As Byte
Dim CipherBlock(0 To 7) As Byte
'Set the key if provided
If (Len(Key) > 0) Then Me.Key = Key
'Get the size of the original array
OrigLen = UBound(ByteArray) + 1
'First we add 12 bytes (4 bytes for the
'length and 8 bytes for the seed values
'for the CBC routine), and the ciphertext
'must be a multiple of 8 bytes
CipherLen = OrigLen + 12
If (CipherLen Mod 8 <> 0) Then
CipherLen = CipherLen + 8 - (CipherLen Mod 8)
End If
ReDim Preserve ByteArray(CipherLen - 1)
Call CopyMem(ByteArray(12), ByteArray(0), OrigLen)
'Store the length descriptor in bytes [9-12]
Call CopyMem(ByteArray(8), OrigLen, 4)
'Store a block of random data in bytes [1-8],
'these work as seed values for the CBC routine
'and is used to produce different ciphertext
'even when encrypting the same data with the
'same key)
Call Randomize
Call CopyMem(ByteArray(0), CLng(2147483647 * Rnd), 4)
Call CopyMem(ByteArray(4), CLng(2147483647 * Rnd), 4)
'Encrypt the data in 64-bit blocks
For Offset = 0 To (CipherLen - 1) Step 8
'Get the next block of plaintext
Call CopyMem(CurrBlock(0), ByteArray(Offset), 8)
'XOR the plaintext with the previous
'ciphertext (CBC, Cipher-Block Chaining)
For a = 0 To 7
CurrBlock(a) = CurrBlock(a) Xor CipherBlock(a)
Next
'Encrypt the block
Call EncryptBlock(CurrBlock())
'Store the block
Call CopyMem(ByteArray(Offset), CurrBlock(0), 8)
'Store the cipherblock (for CBC)
Call CopyMem(CipherBlock(0), CurrBlock(0), 8)
'Update the progress if neccessary
If (Offset >= NextPercent) Then
CurrPercent = Int((Offset / CipherLen) * 100)
NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1
RaiseEvent Progress(CurrPercent)
End If
Next
'Make sure we return a 100% progress
If (CurrPercent <> 100) Then RaiseEvent Progress(100)End Sub