09. februar 2001 - 20:20
#16
<<< Bongo Jungo >>>
TEA Cryptography
Udviklet år 2000 af Fredrik Qvarfort.
Kopier det hele over i en CLASS fil. (eller module)
Select Case DitValg
Case CLASS
Indsæt \"Public etellerandet as New CLASSNAVN\"
Example:
Public Crypt as new TEAEncryption
\'Erstat msgbox med f.eks. text1.text =
Msgbox Crypt.EncryptString(\"DA TEKST\",\"DA KEY\")
\'
Msgbox Crypt.DecryptString.... etc...
Case Module
Put det i en module og bare skriv
? = EncryptString
osv.
End Select
Xafion
<<<CUt\'n\'Paste!>>>
\'TEA Encryption/Decryption Class
Private Declare Sub CopyMem Lib \"kernel32\" Alias \"RtlMoveMemory\" (Destination As Any, Source As Any, ByVal Length As Long)
Private m_RunningCompiled As Boolean
Private Tk(3) As Long
Private Const ROUNDS = 32
Private Const Delta = &H9E3779B9
Private Const DecryptSum = &HC6EF3720 \'Delta * Rounds (precalculated to prevent overflow error)
Public Static Sub GetWord(LongValue As Long, CryptBuffer() As Byte, Offset As Long)
Dim bb(0 To 3) As Byte
bb(3) = CryptBuffer(Offset)
bb(2) = CryptBuffer(Offset + 1)
bb(1) = CryptBuffer(Offset + 2)
bb(0) = CryptBuffer(Offset + 3)
Call CopyMem(LongValue, bb(0), 4)
End Sub
Public Static Sub PutWord(LongValue As Long, CryptBuffer() As Byte, Offset As Long)
Dim bb(0 To 3) As Byte
Call CopyMem(bb(0), LongValue, 4)
CryptBuffer(Offset) = bb(3)
CryptBuffer(Offset + 1) = bb(2)
CryptBuffer(Offset + 2) = bb(1)
CryptBuffer(Offset + 3) = bb(0)
End Sub
Public Static Function UnsignedAdd(ByVal Data1 As Long, Data2 As Long) As Long
Dim x1(0 To 3) As Byte
Dim x2(0 To 3) As Byte
Dim xx(0 To 3) As Byte
Dim Rest As Long
Dim Value As Long
Dim a As Long
Call CopyMem(x1(0), Data1, 4)
Call CopyMem(x2(0), Data2, 4)
Rest = 0
For a = 0 To 3
Value = CLng(x1(a)) + CLng(x2(a)) + Rest
xx(a) = Value And 255
Rest = Value \\ 256
Next
Call CopyMem(UnsignedAdd, xx(0), 4)
End Function
Public Function UnsignedDel(Data1 As Long, Data2 As Long) As Long
Dim x1(0 To 3) As Byte
Dim x2(0 To 3) As Byte
Dim xx(0 To 3) As Byte
Dim Rest As Long
Dim Value As Long
Dim a As Long
Call CopyMem(x1(0), Data1, 4)
Call CopyMem(x2(0), Data2, 4)
Call CopyMem(xx(0), UnsignedDel, 4)
For a = 0 To 3
Value = CLng(x1(a)) - CLng(x2(a)) - Rest
If (Value < 0) Then
Value = Value + 256
Rest = 1
Else
Rest = 0
End If
xx(a) = Value
Next
Call CopyMem(UnsignedDel, xx(0), 4)
End Function
Public Function EncryptString(Text As String, Optional Key As String) As String
Dim ByteArray() As Byte
ByteArray() = StrConv(Text, vbFromUnicode)
Call EncryptByte(ByteArray(), Key)
EncryptString = StrConv(ByteArray(), vbUnicode)
End Function
Public Function DecryptString(Text As String, Optional Key As String) As String
Dim ByteArray() As Byte
ByteArray() = StrConv(Text, vbFromUnicode)
Call DecryptByte(ByteArray(), Key)
DecryptString = StrConv(ByteArray(), vbUnicode)
End Function
Public Sub EncryptByte(ByteArray() As Byte, Optional Key As String)
Dim X As Long
Dim sum As Long
Dim Offset As Long
Dim OrigLen As Long
Dim LeftWord As Long
Dim RightWord As Long
Dim CipherLen As Long
Dim CipherLeft As Long
Dim CipherRight As Long
Dim Sl As Long
Dim Sr As Long
If (Len(Key) > 0) Then Me.Key = Key
\'Get the length 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 64-bit block as two longs
Call GetWord(LeftWord, ByteArray(), Offset)
Call GetWord(RightWord, ByteArray(), Offset + 4)
\'XOR the plaintext with the previous
\'ciphertext (CBC, Cipher-Block Chaining)
LeftWord = LeftWord Xor CipherLeft
RightWord = RightWord Xor CipherRight
\'Encrypt the block
sum = 0
For X = 1 To ROUNDS
If (m_RunningCompiled) Then
sum = (sum + Delta)
Sr = ((RightWord And &HFFFFFFE0) \\ 32) And &H7FFFFFF
LeftWord = LeftWord + (((RightWord * 16) + Tk(0)) Xor (RightWord + sum) Xor (Sr + Tk(1)))
Sl = ((LeftWord And &HFFFFFFE0) \\ 32) And &H7FFFFFF
RightWord = RightWord + (((LeftWord * 16) + Tk(2)) Xor (LeftWord + sum) Xor (Sl + Tk(3)))
Else
sum = UnsignedAdd(sum, Delta)
LeftWord = UnsignedAdd(LeftWord, (UnsignedAdd(LShift4(RightWord), Tk(0)) Xor UnsignedAdd(RightWord, sum) Xor UnsignedAdd(RShift5(RightWord), Tk(1))))
RightWord = UnsignedAdd(RightWord, (UnsignedAdd(LShift4(LeftWord), Tk(2)) Xor UnsignedAdd(LeftWord, sum) Xor UnsignedAdd(RShift5(LeftWord), Tk(3))))
End If
Next
\'Store the block
Call PutWord(LeftWord, ByteArray(), Offset)
Call PutWord(RightWord, ByteArray(), Offset + 4)
\'Store the cipherblocks (for CBC)
CipherLeft = LeftWord
CipherRight = RightWord
Next
End Sub
Private Static Function LShift4(Data1 As Long) As Long
Dim x1(0 To 3) As Byte
Dim xx(0 To 3) As Byte
Call CopyMem(x1(0), Data1, 4)
xx(0) = ((x1(0) And 15) * 16)
xx(1) = ((x1(1) And 15) * 16) Or ((x1(0) And 240) \\ 16)
xx(2) = ((x1(2) And 15) * 16) Or ((x1(1) And 240) \\ 16)
xx(3) = ((x1(3) And 15) * 16) Or ((x1(2) And 240) \\ 16)
Call CopyMem(LShift4, xx(0), 4)
End Function
Private Static Function RShift5(Data1 As Long) As Long
Dim x1(0 To 3) As Byte
Dim xx(0 To 3) As Byte
Call CopyMem(x1(0), Data1, 4)
xx(0) = ((x1(0) And 224) \\ 32) Or ((x1(1) And 31) * 8)
xx(1) = ((x1(1) And 224) \\ 32) Or ((x1(2) And 31) * 8)
xx(2) = ((x1(2) And 224) \\ 32) Or ((x1(3) And 31) * 8)
xx(3) = ((x1(3) And 224) \\ 32)
Call CopyMem(RShift5, xx(0), 4)
End Function
Public Sub DecryptByte(ByteArray() As Byte, Optional Key As String)
Dim X As Long
Dim sum As Long
Dim Offset As Long
Dim OrigLen As Long
Dim LeftWord As Long
Dim RightWord As Long
Dim CipherLen As Long
Dim CipherLeft As Long
Dim CipherRight As Long
Dim CurrPercent As Long
Dim NextPercent As Long
Dim Sr As Long
Dim Sl As Long
\'Set the new key if provided
If (Len(Key) > 0) Then Me.Key = Key
\'Get the length of the bytearray
CipherLen = UBound(ByteArray) + 1
\'Tk(0) = 16
\'Tk(1) = 16
\'Tk(2) = 16
\'Tk(3) = 16
For Offset = 0 To (CipherLen - 1) Step 8
\'Get the next block of ciphertext
Call GetWord(LeftWord, ByteArray(), Offset)
Call GetWord(RightWord, ByteArray(), Offset + 4)
sum = DecryptSum
For X = 1 To ROUNDS
If (m_RunningCompiled) Then
Sl = ((LeftWord And &HFFFFFFE0) \\ 32) And &H7FFFFFF
RightWord = RightWord - (((LeftWord * 16) + Tk(2)) Xor (LeftWord + sum) Xor (Sl + Tk(3)))
Sr = ((RightWord And &HFFFFFFE0) \\ 32) And &H7FFFFFF
LeftWord = LeftWord - (((RightWord * 16) + Tk(0)) Xor (RightWord + sum) Xor (Sr + Tk(1)))
sum = (sum - Delta)
Else
RightWord = UnsignedDel(RightWord, (UnsignedAdd(LShift4(LeftWord), Tk(2)) Xor UnsignedAdd(LeftWord, sum) Xor UnsignedAdd(RShift5(LeftWord), Tk(3))))
LeftWord = UnsignedDel(LeftWord, (UnsignedAdd(LShift4(RightWord), Tk(0)) Xor UnsignedAdd(RightWord, sum) Xor UnsignedAdd(RShift5(RightWord), Tk(1))))
sum = UnsignedDel(sum, Delta)
End If
Next
\'XOR with the previous cipherblock
LeftWord = LeftWord Xor CipherLeft
RightWord = RightWord Xor CipherRight
\'Store the current ciphertext to use
\'XOR with the next block plaintext
Call GetWord(CipherLeft, ByteArray(), Offset)
Call GetWord(CipherRight, ByteArray(), Offset + 4)
\'Store the block
Call PutWord(LeftWord, ByteArray(), Offset)
Call PutWord(RightWord, ByteArray(), Offset + 4)
\'Update the progress if neccessary
Next
\'Get the size of the original array
Call CopyMem(OrigLen, ByteArray(8), 4)
\'Make sure OrigLen is a reasonable value,
\'if we used the wrong key the next couple
\'of statements could be dangerous (GPF)
If (CipherLen - OrigLen > 19) Or (CipherLen - OrigLen < 12) Then
Call Err.Raise(vbObjectError, , \"Incorrect size descriptor in TEA decryption\")
End If
\'Resize the bytearray to hold only the plaintext
\'and not the extra information added by the
\'encryption routine
Call CopyMem(ByteArray(0), ByteArray(12), OrigLen)
ReDim Preserve ByteArray(OrigLen - 1)
End Sub
Public Property Let Key(New_Value As String)
Dim K() As Byte
Dim w(0 To 3) As Byte
\'Convert the key to a bytearray and if
\'needed resize it to be exactly 128-bit
K() = StrConv(New_Value, vbFromUnicode)
If (Len(New_Value) < 16) Then ReDim Preserve K(15)
w(0) = K(3)
w(1) = K(2)
w(2) = K(1)
w(3) = K(0)
Call CopyMem(Tk(0), w(0), 4)
w(0) = K(7)
w(1) = K(6)
w(2) = K(5)
w(3) = K(4)
Call CopyMem(Tk(1), w(0), 4)
w(0) = K(11)
w(1) = K(10)
w(2) = K(9)
w(3) = K(8)
Call CopyMem(Tk(2), w(0), 4)
w(0) = K(15)
w(1) = K(14)
w(2) = K(13)
w(3) = K(12)
Call CopyMem(Tk(3), w(0), 4)
End Property
Private Sub Class_Initialize()
\'We need to check if we are running in compiled
\'(EXE) mode or in the IDE, this will allow us to
\'use optimized code with unsigned integers in
\'compiled mode without any overflow errors when
\'running the code in the IDE
On Local Error Resume Next
m_RunningCompiled = ((2147483647 + 1) < 0)
End Sub
